Megatest

utils/build/*
*~
*.o
bin/*
megatest.db
monitor.db
megatest
dboard
tests/fullrun/tmp/*
tests/simpleruns
tests/simplelinks
mkdeploy/runs
mkdeploy/links
example/linktree
example/runs
*.backup
mkdeploy/linktree
mkdeploy/site.config
deploytarg/*
mtest
newdboard
*.log
fslsync/fslsynclinks/*
fslsync/fslsyncruns/*
sites.dat
fullrun/config/*.config
fullrun/envfile.txt
*.bak
simplerun/*.scm
simplerun/simpleruns
tests/mintest/runs/*
tests/mintest/linktree/*
tests/installall/stdrel/*
tests/installall/runs/*
tests/installall/links/*
tests/fdktestqa/simpleruns/*
tests/installall/megatest.db
tests/installall/monitor.db
tests/megatest.db
tests/fdktestqa/simplelinks/*
tests/fdktestqa/testqa/megatest.db
tests/fdktestqa/testqa/monitor.db
megatest-fossil-hash.scm

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
PREFIX=$(PWD)
CSCOPTS= 
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
           ods.scm runconfig.scm server.scm configf.scm \
           db.scm keys.scm margs.scm megatest-version.scm \
           process.scm runs.scm tasks.scm tests.scm genexample.scm \
	   fs-transport.scm http-transport.scm \
           client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
	   tree.scm ezsteps.scm lock-queue.scm sdb.scm

GUISRCF  = dashboard-tests.scm dashboard-guimonitor.scm 

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)

ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')

CSIPATH=$(shell which csi)
CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))

all : mtest dboard newdboard txtdb

refdb : txtdb/txtdb.scm
	csc -I txtdb txtdb/txtdb.scm -o refdb

mtest: $(OFILES) megatest.o
	csc $(CSCOPTS) $(OFILES) megatest.o -o mtest

dboard : $(OFILES) $(GOFILES) dashboard.scm
	csc $(OFILES) dashboard.scm $(GOFILES) -o dboard

newdboard : newdashboard.scm $(OFILES) $(GOFILES)
	csc $(OFILES) $(GOFILES) newdashboard.scm -o newdboard

$(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
	csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl

deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so
	for i in iup im cd av call sqlite; do \
	  cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \
	done
	cp $(CKPATH)/include/*.h deploytarg

# puts deployed megatest in directory "megatest"

tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o  : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm

# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm  run-tests-queue-new.scm

megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
	echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
	if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi

$(OFILES) $(GOFILES) : common_records.scm 

$(HELPERS) : utils/mt_* 
	$(INSTALL) $< $@
	chmod a+x $@

$(DEPLOYHELPERS) : utils/mt_*
	$(INSTALL) $< $@
	chmod a+X $@

$(PREFIX)/bin/mt_xterm : utils/mt_xterm
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/nbfake : utils/nbfake
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/nbfind : utils/nbfind
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/refdb : refdb
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/nbfake : utils/nbfake
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/nbfind : utils/nbfind
	$(INSTALL) $< $@
	chmod a+x $@


# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/dboard : dboard $(FILES)
	$(INSTALL) dboard $(PREFIX)/bin/dboard
	utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard
	chmod a+x $(PREFIX)/bin/dashboard

install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
          $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl

deploytarg/apropos.so : Makefile
	for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \
	chicken-install -prefix deploytarg -deploy $$i;done

deploytarg/libsqlite3.so : 
	CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3



deploy : deploytarg/megatest deploytarg/dashboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/nbfind deploytarg/libiupcd.so deploytarg/apropos.so


bin : 
	mkdir -p $(PREFIX)/bin

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm

clean : 
	rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o

[87cbe68f31] 
[be405e8e2e]

# FROM andyjpg on #chicken

(let ((original-exit (exit-handler)))
  (exit-handler (lambda (#!optional (exit-code 0))
		  (printf "Preparing to exit...\n" exit-code)
		  (for-each (lambda (pid)
			      (printf "Sending signal/term to ~A\n" pid)
			      (process-signal pid signal/term)) (children))
		  (original-exit exit-code))))



1. All run control access to db is direct.
2. All test machines must have megatest available
3. Tests may or may not have file system access to the originating
   run area. rsync is used to pull the test area to the home host
   if and only if the originating area can not be seen via file 
   system. NO LONGER TRUE. Rsync is used but file system must be visible.
4. All db access is done via the home host. NOT IMPLEMENTED YET.

REMOTE ACCESS DB LOADS

INFO: (0) Max cached queries was    10
INFO: (0) Number of cached writes   27043
INFO: (0) Average cached write time 15.0634544983915 ms
INFO: (0) Number non-cached queries 71928
INFO: (0) Average non-cached time   5.15547491936381 ms
INFO: (0) Server shutdown complete. Exiting


fdktestqa on Apr 29, 2013: 1812 tests

INFO: (0) Max cached queries was    10
INFO: (0) Number of cached writes   41335
INFO: (0) Average cached write time 206.081553163179 ms
INFO: (0) Number non-cached queries 74289

1. Confirm that branch transaction-for-sequential-writes content was added to trunk/development
2. Add a host chooser for ssh to launch-tests










3. Try making static executable

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
;; (use zmq)

(import (prefix sqlite3 sqlite3:))

(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils)

(declare (unit client))

(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

    ok))

;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios. 
;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;;   2. We are a run tests, list runs or other interactive process and we must figure out
;;      *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
(define (client:setup #!key (numtries 3))
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: failed to find megatest.config, exiting")
	    (exit))))
  (push-directory *toppath*) ;; This is probably NOT needed 
  (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*)

  (let* ((hostinfo  (open-run-close tasks:get-best-server tasks:open-db)))



    (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo)
    (set! *transport-type* (if hostinfo 
    			       (string->symbol (tasks:hostinfo-get-transport hostinfo))
			       'fs))



    (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) ""))
    (case *transport-type* 
      ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))









      ((http)
       (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				      (tasks:hostinfo-get-port hostinfo)))
      ((zmq)
       (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				     (tasks:hostinfo-get-port      hostinfo)
				     (tasks:hostinfo-get-pubport   hostinfo)))
      (else  ;; default to fs
       (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs")
       (set! *transport-type* 'fs)
       (set! *megatest-db*    (open-db))))
    (pop-directory)))

;; client:signal-handler
(define (client:signal-handler signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()

(define *waiting-queue*     (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar

;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    'fs)
(define *megatest-db*       #f)
(define *rpc:listener*      #f) ;; if set up for server communication this will hold the tcp port
(define *runremote*         #f) ;; if set up for server communication this will hold <host port>
(define *last-db-access*    (current-seconds))  ;; update when db is accessed via server
(define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id*         #f)
(define *server-info*       #f)
(define *time-to-exit*      #f)
(define *received-response* #f)
(define *default-numtries*  10)
(define *server-run*        #t)
(define *db-write-access*   #t)


(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys*              (make-hash-table)) ;; cache the keys here
(define *keyvals*           (make-hash-table))
(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
(define *test-info*         (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db

(define *run-info-cache*    (make-hash-table)) ;; run info is stable, no need to reget

;; Awful. Please FIXME
(define *env-vars-by-run-id* (make-hash-table))
(define *current-run-name*   #f)

;; Testconfig and runconfig caches. 
(define *testconfigs*       (make-hash-table)) ;; test-name => testconfig
(define *runconfigs*        (make-hash-table)) ;; target    => runconfig

;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than
;; five seconds ago
(define *pre-reqs-met-cache* (make-hash-table))

(define (common:clear-caches)
  (set! *target*             (make-hash-table))
  (set! *keys*               (make-hash-table))
  (set! *keyvals*            (make-hash-table))
  (set! *toptest-paths*      (make-hash-table))
  (set! *test-paths*         (make-hash-table))
  (set! *test-ids*           (make-hash-table))
  (set! *test-info*          (make-hash-table))
  (set! *run-info-cache*     (make-hash-table))
  (set! *env-vars-by-run-id* (make-hash-table))
  (set! *test-id-cache*      (make-hash-table)))

;;======================================================================
;; S T A T E S   A N D   S T A T U S E S
;;======================================================================

(define *common:std-states*   
  (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ" "STUCK"))

(define *common:std-statuses*
  (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD"))

;; These are stopping conditions that prevent a test from being run
(define *common:cant-run-states-sym* 
  '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))

;;======================================================================
;; D E B U G G I N G   S T U F F 
;;======================================================================

(define *verbosity*         1)
(define *logging*           #f)

(define (get-with-default val default)
  (let ((val (args:get-arg val)))
    (if val val default)))

(define (assoc/default key lst . default)
  (let ((res (assoc key lst)))
    (if res (cadr res)(if (null? default) #f (car default)))))

;;======================================================================
;; Misc utils
;;======================================================================

;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
(define (common:hms-string->seconds tstr)
  (let ((parts     (string-split tstr))
	(time-secs 0)
	;; s=seconds, m=minutes, h=hours, d=days
	(trx       (regexp "(\\d+)([smhd])")))
    (for-each (lambda (part)
		(let ((match  (string-match trx part)))
		  (if match
		      (let ((val (string->number (cadr match)))
			    (unt (caddr match)))
			(if val 
			    (set! time-secs (+ time-secs (* val
							    (case (string->symbol unt)
							      ((s) 1)
							      ((m) 60)
							      ((h) (* 60 60))
							      ((d) (* 24 60 60))
							      (else 0))))))))))
	      parts)
    time-secs))
		       
(define (common:version-signature)
  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

;; one-of args defined
(define (args-defined? . param)
  (let ((res #f))
    (for-each 
     (lambda (arg)
       (if (args:get-arg arg)(set! res #t)))
     param)

			       #f #t))) string<?))

;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks)
  (hash-table-ref/default 
   (read-config "megatest.config" #f #t)
   "disks" '("none" "")))

;;======================================================================
;; M I S C   L I S T S
;;======================================================================

;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
;;
(define (common:list-is-sublist lista listb)
  (if (null? lista)
      listb ;; all items in listb are "remaining"
      (if (> (length lista)(length listb)) 
	  #f
	  (let loop ((heda (car lista))
		     (tala (cdr lista))
		     (hedb (car listb))
		     (talb (cdr listb)))
	    (if (equal? heda hedb)
		(if (null? tala) ;; we are done
		    talb
		    (loop (car tala)
			  (cdr tala)
			  (car talb)
			  (cdr talb)))
		#f)))))

;; Needed for long lists to be sorted where (apply max ... ) dies
;;
(define (common:max inlst)
  (let loop ((max-val (car inlst))
	     (hed     (car inlst))
	     (tal     (cdr inlst)))
    (if (not (null? tal))
	(loop (max hed max-val)
	      (car tal)
	      (cdr tal))
	(max hed max-val))))


;;======================================================================
;; Munge data into nice forms
;;======================================================================

;; Generate an index for a sparse list of key values
;;   ( (rowname1 colname1 val1)(rowname2 colname2 val2) )
;;
;; => 
;;
;;   ( (rowname1 0)(rowname2 1))    ;; rownames -> num
;;     (colname1 0)(colname2 1)) )  ;; colnames -> num
;; 
;; optional apply proc to rownum colnum value
(define (common:sparse-list-generate-index data #!key (proc #f))
  (if (null? data)
      (list '() '())
      (let loop ((hed (car data))
		 (tal (cdr data))
		 (rownames '())
		 (colnames '())
		 (rownum   0)
		 (colnum   0))
	(let* ((rowkey          (car   hed))
	       (colkey          (cadr  hed))
	       (value           (caddr hed))
	       (existing-rowdat (assoc rowkey rownames))
	       (existing-coldat (assoc colkey colnames))
	       (curr-rownum     (if existing-rowdat rownum (+ rownum 1)))
	       (curr-colnum     (if existing-coldat colnum (+ colnum 1)))
	       (new-rownames    (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames)))
	       (new-colnames    (if existing-coldat colnames (cons (list colkey curr-colnum) colnames))))
	  ;; (debug:print-info 0 "Processing record: " hed )
	  (if proc (proc curr-rownum curr-colnum rowkey colkey value))
	  (if (null? tal)
	      (list new-rownames new-colnames)
	      (loop (car tal)
		    (cdr tal)
		    new-rownames
		    new-colnames
		    (if (> curr-rownum rownum) curr-rownum rownum)
		    (if (> curr-colnum colnum) curr-colnum colnum)
		    ))))))

;;======================================================================
;; System stuff
;;======================================================================

;; return a nice clean pathname made absolute
(define (nice-path dir)

(define (get-uname . params)
  (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
	 (uname #f))
    (if (null? (car uname-res))
	"unknown"
	(caar uname-res))))
	      
(define (save-environment-as-files fname #!key (ignorevars (list "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR")))
  (let ((envvars (get-environment-variables))
        (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")))
     (with-output-to-file (conc fname ".csh")
       (lambda ()
          (for-each (lambda (key)
		      (if (not (member key ignorevars))
			  (let* ((val (cdr key))
				 (sval (if (string-search whitesp val)(conc "\"" val "\"") val)))
			    (print "setenv " (car key) " " sval))))
		      envvars)))
     (with-output-to-file (conc fname ".sh")
       (lambda ()
          (for-each (lambda (key)
		      (if (not (member key ignorevars))
			  (let* ((val (cdr key))
				 (sval (if (string-search whitesp val)(conc "\"" val "\"") val)))
			    (print "export " (car key) "=" sval))))
                    envvars)))))

;; set some env vars from an alist, return an alist with original values
;; (("VAR" "value") ...)
(define (alist->env-vars lst)
  (if (list? lst)
      (let ((res '()))

	  (if (> min 0)(conc min "m ")  "")
	  sec "s")))

(define (seconds->time-string sec)
  (time->string 
   (seconds->local-time sec) "%H:%M:%S"))

(define (seconds->work-week/day-time sec)
  (time->string
   (seconds->local-time sec) "ww%V.%u %H:%M"))

(define (seconds->work-week/day sec)
  (time->string
   (seconds->local-time sec) "ww%V.%u"))

(define (seconds->year-work-week/day sec)
  (time->string
   (seconds->local-time sec) "%yww%V.%w"))

(define (seconds->year-work-week/day-time sec)
  (time->string
   (seconds->local-time sec) "%yww%V.%w %H:%M"))

;;======================================================================
;; Colors
;;======================================================================
      
(define (common:name->iup-color name)
  (case (string->symbol (string-downcase name))
    ((red)    "223 33 49")
    ((grey)   "192 192 192")
    ((orange) "255 172 13")
    ((purple) "This is unfinished ...")))

;; (define (common:get-color-for-state-status state status)
;;   (case (string->symbol state)
;;     ((COMPLETED)
;;      (case (string->symbol status)
;;        ((PASS)        "70  249 73")
;;        ((WARN WAIVED) "255 172 13")
;;        ((SKIP)        "230 230 0")
;;        (else "223 33 49")))
;;     ((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")))

(define (common:get-color-from-status status)
  (cond
   ((equal? status "PASS")    "green")
   ((equal? status "FAIL")    "red")
   ((equal? status "WARN")    "orange")
   ((equal? status "KILLED")  "orange")
   ((equal? status "KILLREQ") "purple")
   ((equal? status "RUNNING") "blue")
   (else "black")))

				    (conc *verbosity*))))))
  

(define (debug:print n . params)
  (if (debug:debug-mode n)
      (with-output-to-port (current-error-port)
	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      (apply print params)
	      )))))

(define (debug:print-info n . params)
  (if (debug:debug-mode n)
      (with-output-to-port (current-error-port)
	(lambda ()
	  (let ((res (format#format #f "INFO: (~2d) ~a" n (apply conc params))))
	    (if *logging*
		(db:log-event res)
		(apply print "INFO: (" n ") " params) ;; res)
		))))))

;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))

;;======================================================================

(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
(define configf:blank-l-rx (regexp "^\\s*$"))
(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
(define configf:comment-rx (regexp "^\\s*#.*"))
(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))

;; read a line and process any #{ ... } constructs

(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)"))
(define (configf:process-line l ht)

    (if targ
	(or (configf:lookup config targ var)
	    (configf:lookup config "default" var))
	(configf:lookup config "default" var))))

(define-inline (configf:read-line p ht allow-processing)
  (let loop ((inl (read-line p)))
    (let ((cont-line (and (string? inl)
			  (not (string-null? inl))
			  (equal? "\\" (string-take-right inl 1)))))
      (if cont-line ;; last character is \ 
	  (let ((nextl (read-line p)))
	    (if (not (eof-object? nextl))
		(loop (string-append (if cont-line 
					 (string-take inl (- (string-length inl) 1))
					 inl)
				     nextl))))
	  (if (and allow-processing 
		   (not (eq? allow-processing 'return-string)))
	      (configf:process-line inl ht)
	      inl)))))

;; read a config file, returns hash table of alists

;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f))
  (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory))
  (if (not (file-exists? path))
      (begin 
	(debug:print-info 1 "read-config - file not found " path " current path: " (current-directory))
	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
	#f) ;; (if (not ht)(make-hash-table) ht))
      (let ((inp        (open-input-file path))
	    (res        (if (not ht)(make-hash-table) ht)))
	(let loop ((inl               (configf:read-line inp res allow-system)) ;; (read-line inp))
		   (curr-section-name (if curr-section curr-section "default"))
		   (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
		   (lead     #f))
	  (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n   inl: \"" inl "\"")

												    (case allow-system
												      ((return-procs) val-proc)
												      ((return-string) cmd)
												      (else (val-proc)))))
							    (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
							  (loop (configf:read-line inp res allow-system) curr-section-name #f #f)))
	       (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist   (hash-table-ref/default res curr-section-name '()))
								  (envar   (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
								  (realval (if envar
									       (config:eval-string-in-environment val)
									       val)))
							     (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
							     (if envar
								 (begin
								   ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval)
								   (setenv key realval)))
							     (hash-table-set! res curr-section-name 
									      (config:assoc-safe-add alist key realval))
							     (loop (configf:read-line inp res allow-system) curr-section-name key #f)))
	       (configf:key-no-val ( x key val)             (let* ((alist   (hash-table-ref/default res curr-section-name '())))
							      (hash-table-set! res curr-section-name 
									       (config:assoc-safe-add alist key #t))
							      (loop (configf:read-line inp res allow-system) curr-section-name key #f)))
	       ;; if a continued line
	       (configf:cont-ln-rx ( x whsp val     ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(if var-flag             ;; if set to a string then we have a continued var
						    (let ((newval (conc 
								   (config-lookup res curr-section-name var-flag) "\n"
								   ;; trim lead from the incoming whsp to support some indenting.
								   (if lead

(define (configf:section-vars cfgdat section)
  (let ((sectdat (hash-table-ref/default cfgdat section '())))
    (if (null? sectdat)
	'()
	(map car sectdat))))

(define (configf:get-section cfgdat section)
  (hash-table-ref/default cfgdat section '()))

(define (setup)
  (let* ((configf (find-config))
	 (config  (if configf (read-config configf #f #t) #f)))
    (if config
	(setenv "RUN_AREA_HOME" (pathname-directory configf)))

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses ezsteps))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(define (test-info-panel testdat store-label widgets)
  (iup:frame 
   #:title "Test Info" ; #:expand "YES"
   (iup:hbox ; #:expand "YES"
    (apply iup:vbox ; #:expand "YES"
	   (append (map (lambda (val)
			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Testname: "
			      "Item path: "
			      "Current state: "
			      "Current status: "
			      "Test comment: "
			      "Test id: "
			      "Test date: "))
		   (list (iup:label "" #:expand "VERTICAL"))))
    (apply iup:vbox  ; #:expand "YES"
	   (list 
	    (store-label "testname"
			 (iup:label (db:test-get-testname  testdat) #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-testname testdat)))
	    (store-label "item-path"
			 (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-item-path testdat)))
	    (store-label "teststate" 
			 (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (db:test-get-state testdat)))
	    (let ((lbl   (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL")))
	      (hash-table-set! widgets "teststatus"
			       (lambda (testdat)
				 (let ((newstatus (db:test-get-status testdat))
				       (oldstatus (iup:attribute lbl "TITLE")))
				   (if (not (equal? oldstatus newstatus))
				       (begin
					 (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat)
														   (db:test-get-status testdat))))
					 (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat)))))))
	      lbl)
	    (store-label "testcomment"
			 (iup:label "TestComment                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (let ((newcomment (db:test-get-comment testdat)))
			     (if *dashboard-comment-share-slot*
				 (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE")
						  newcomment))
				     (iup:attribute-set! *dashboard-comment-slot*
							 "VALUE"
							 newcomment)))
			     newcomment)))
	    (store-label "testid"
			 (iup:label "TestId                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (db:test-get-id testdat)))
	    (store-label "testdate" 
			 (iup:label "TestDate                           "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (seconds->work-week/day-time (db:test-get-event_time testdat))))
	    )))))

;;======================================================================
;; Test meta panel
;;======================================================================

(define (test-meta-panel-get-description testmeta)

	    )))))


;;======================================================================
;; Run info panel
;;======================================================================
(define (run-info-panel keydat testdat runname)
  (let* ((run-id     (db:test-get-run_id testdat))
	 (rundat     (cdb:remote-run db:get-run-info #f run-id))
	 (header     (db:get-header rundat))
	 (event_time (db:get-value-by-header (db:get-row rundat)
					     (db:get-header rundat)
					     "event_time")))
    (iup:frame 
     #:title "Megatest Run Info" ; #:expand "YES"
     (iup:hbox ; #:expand "YES"
      (apply iup:vbox ; #:expand "YES"
	     (append (map (lambda (keyval)
			    (iup:label (conc (car keyval) " ")))

			  keydat)
		     (list (iup:label "runname ")
			   (iup:label "run-id")
			   (iup:label "run-date"))))
      (apply iup:vbox
	     (append (map (lambda (keyval)
			    (iup:label (cadr keyval) #:expand "HORIZONTAL"))
			  keydat)
		     (list (iup:label runname)
			   (iup:label (conc run-id))
			   (iup:label (seconds->year-work-week/day-time event_time))
			   (iup:label "" #:expand "VERTICAL"))))))))
  
;;======================================================================
;; Host info panel
;;======================================================================
(define (host-info-panel testdat store-label)
  (iup:frame
   #:title "Remote host and Test Run Info" ; #:expand "YES"

;; use a global for setting the buttons colors
;;                           state status teststeps
(define *state-status* (vector #f #f #f))
(define (update-state-status-buttons testdat)
  (let* ((state  (db:test-get-state  testdat))
	 (status (db:test-get-status testdat))
	 (color  (car (gutils:get-color-for-state-status state status))))
    ((vector-ref *state-status* 0) state color)
    ((vector-ref *state-status* 1) status color)))

(define *dashboard-test-db* #t)
(define *dashboard-comment-share-slot* #f)

;;======================================================================
;; Set fields 
;;======================================================================
(define (set-fields-panel test-id testdat #!key (db #f))
  (let ((newcomment #f)
	(newstatus  #f)
	(newstate   #f)
	(wtxtbox    #f))
    (iup:frame
     #:title "Set fields"
     (iup:vbox
      (iup:hbox (iup:label "Comment:")
		(let ((txtbox (iup:textbox #:action (lambda (val a b)
						      ;; IDEA: Just set a variable with the proc to call?
						      (open-run-close db:test-set-state-status-by-id db test-id #f #f b)
						      (set! newcomment b))
					   #:value (db:test-get-comment testdat)
					   #:expand "HORIZONTAL")))
		  (set! wtxtbox txtbox)
		  txtbox))
		  
      (apply iup:hbox
	     (iup:label "STATE:" #:size "30x")
	     (let* ((btns  (map (lambda (state)
				  (let ((btn (iup:button state
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (open-run-close db:test-set-state-status-by-id db test-id state #f #f)
								    (db:test-set-state! testdat state)))))
				    btn))
				*common:std-states*))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
	       (vector-set! *state-status* 0
			    (lambda (state color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name state) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
				       (iup:attribute-set! btn "BGCOLOR" newcolor))))
			       btns)))
	       btns))
      (apply iup:hbox
	     (iup:label "STATUS:" #:size "30x")
	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (let ((t (iup:attribute x "TITLE")))
								      (if (equal? t "WAIVED")
									  (iup:show (dashboard-tests:waiver testdat 
													    (if wtxtbox (iup:attribute wtxtbox "VALUE") #f)
													    (lambda (c)
													      (set! newcomment c)
													      (if wtxtbox 
														  (begin
														    (iup:attribute-set! wtxtbox "VALUE" c)
														    (if (not *dashboard-comment-share-slot*)
															(set! *dashboard-comment-share-slot* wtxtbox)))
														  ))))
									  (begin
									    (open-run-close db:test-set-state-status-by-id db test-id #f status #f)
									    (db:test-set-status! testdat status))))))))
				    btn))
				*common:std-statuses*))) ;; (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name status) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
				       (iup:attribute-set! btn "BGCOLOR" newcolor))))
			       btns)))
	       btns))))))

(define (dashboard-tests:run-html-viewer lfilename)
  (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
    (if htmlviewercmd
	(system (conc "(" htmlviewercmd " " lfilename " ) &")) 
	(iup:send-url lfilename))))

(define (dashboard-tests:run-a-step info)
  #t)

(define (dashboard-tests:step-run-control testdat stepname testconfig)
  (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES"
   #:title stepname
   (iup:vbox ; #:expand "YES"
    (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done."))
    (iup:button "Re-run"            
		#:expand "HORIZONTAL" 
		#:action (lambda (obj)
			   (thread-start! 
			    (make-thread (lambda ()
					   (ezsteps:run-from testdat stepname #t))
					 (conc "ezstep run single step " stepname)))))
    (iup:button "Re-run and continue"         
		#:expand "HORIZONTAL" 
		#:action (lambda (obj)
			   (thread-start!
			    (make-thread (lambda ()
					   (ezsteps:run-from testdat stepname #f))
					 (conc "ezstep run from step " stepname)))))
    ;; (iup:button "Refresh test data"
    ;;     	#:expand "HORIZONTAL"
    ;;     	#:action (lambda (obj)
    ;;     		   (print "Refresh test data " stepname))
    )))

(define (dashboard-tests:waiver testdat ovrdval cmtcmd)
  (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt"))
	 (wregx (if (string? wpatt)(regexp wpatt) #f))
	 (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) "")))
	 (comnt (iup:textbox #:action (lambda (val a b)
					(if wpatt
					    (if (string-match wregx b)
						(iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt))
						(iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt))
						)))
			     #:value (if ovrdval ovrdval (db:test-get-comment testdat))
			     #:expand "HORIZONTAL"))
	 (dlog  #f))
    (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES"
		#:title "SET WAIVER"
		(iup:vbox ; #:expand "YES"
		 (iup:label (conc "Enter justification for waiving test "
				  (db:test-get-testname testdat)
				  (if (equal? (db:test-get-item-path testdat) "") 
				      ""
				      (conc "/" (db:test-get-item-path testdat)))))
		 wmesg ;; the informational msg on whether it matches
		 comnt
		 (iup:hbox
		  (iup:button "Apply and Close "
			      #:expand "HORIZONTAL"
			      #:action (lambda (obj)
					 (let ((comment (iup:attribute comnt "VALUE"))
					       (test-id (db:test-get-id testdat)))
					   (if (or (not wpatt)
						   (string-match wregx comment))
					       (begin
						 (open-run-close db:test-set-state-status-by-id #f test-id #f "WAIVED" comment)
						 (db:test-set-status! testdat "WAIVED")
						 (cmtcmd comment)
						 (iup:destroy! dlog))))))
		  (iup:button "Cancel"
			      #:expand "HORIZONTAL" 
			      #:action (lambda (obj)
					 (iup:destroy! dlog)))))))
    dlog))

;;======================================================================
;;
;;======================================================================
(define (examine-test test-id) ;; run-id run-key origtest)

  (let* ((db-path       (conc *toppath* "/megatest.db"))
	 (db            (open-db))
	 (testdat       (open-run-close db:get-test-info-by-id db test-id))
	 (db-mod-time   0) ;; (file-modification-time db-path))
	 (last-update   0) ;; (current-seconds))
	 (request-update #t))

    (if (not testdat)
	(begin
	  (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
	  (exit 1))
	(let* ((run-id        (if testdat (db:test-get-run_id testdat) #f))
	       (keydat        (if testdat (open-run-close db:get-key-val-pairs db run-id) #f))
	       (rundat        (if testdat (open-run-close db:get-run-info db run-id) #f))
	       (runname       (if testdat (db:get-value-by-header (db:get-row rundat)
								  (db:get-header rundat)
								  "runname") #f))
	       ;; These next two are intentional bad values to ensure errors if they should not
	       ;; get filled in properly.
	       (logfile       "/this/dir/better/not/exist")
	       (rundir        logfile)
	       (testdat-path  (conc rundir "/testdat.db")) ;; this gets recalculated until found 
	       (teststeps     (if testdat (db:get-compressed-steps test-id work-area: rundir) '()))
	       (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	       (testname      (if testdat (db:test-get-testname testdat) "n/a"))
	       (testmeta      (if testdat 
				  (let ((tm (open-run-close db:testmeta-get-record db testname)))
				    (if tm tm (make-db:testmeta)))
				  (make-db:testmeta)))

	       (keystring  (string-intersperse 
			    (map (lambda (keyval)
				   ;; (conc ":" (car keyval) " " (cadr keyval)))
				   (cadr keyval))
				 keydat)
			    "/"))
	       (item-path  (db:test-get-item-path testdat))
	       (viewlog    (lambda (x)
			     (if (file-exists? logfile)
					;(system (conc "firefox " logfile "&"))
				 (dashboard-tests:run-html-viewer logfile)
				 (message-window (conc "File " logfile " not found")))))
	       (view-a-log (lambda (lfile) 
			     (let ((lfilename (conc rundir "/" lfile)))
			       ;; (print "lfilename: " lfilename)
			       (if (file-exists? lfilename)
					;(system (conc "firefox " logfile "&"))
				   (dashboard-tests:run-html-viewer lfilename)
				   (message-window (conc "File " lfilename " not found"))))))
	       (xterm      (lambda (x)
			     (if (directory-exists? rundir)
				 (let ((shell (if (get-environment-variable "SHELL") 
						  (conc "-e " (get-environment-variable "SHELL"))
						  "")))
				   (system (conc "cd " rundir 
						 ";mt_xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
				 (message-window  (conc "Directory " rundir " not found")))))
	       (widgets    (make-hash-table))
	       (refreshdat (lambda ()
			     (let* ((curr-mod-time (max (file-modification-time db-path)
							(if (file-exists? testdat-path)
							    (file-modification-time testdat-path)
							    (begin
							      (set! testdat-path (conc rundir "/testdat.db"))
							      0))))
				    (need-update   (or (and (> curr-mod-time db-mod-time)
							    (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
						       (> (current-milliseconds)(+ last-update 10000))     ;; force update even 10 seconds
						       request-update))
				    (newtestdat (if need-update 
						    ;; NOTE: BUG HIDER, try to eliminate this exception handler
						    (handle-exceptions
						     exn 
						     (debug:print-info 0 "WARNING: test db access issue for test " test-id ": " ((condition-property-accessor 'exn 'message) exn))
						     (make-db:test)
						     (let* ((newdat (open-run-close db:get-test-info-by-id db test-id ))
							    (tstdat (if newdat
									(open-run-close tests:testdat-get-testinfo db test-id #f)
									'())))
						       (if (and newdat 
								(not (null? tstdat))) ;; (update-time cpuload diskfree run-duration)
							   (let* ((rec      (car tstdat))
								  (cpuload  (vector-ref rec 1))
								  (diskfree (vector-ref rec 2))
								  (run-dur  (vector-ref rec 3)))
							     (db:test-set-run_duration! newdat run-dur)
							     (db:test-set-diskfree!     newdat diskfree)
							     (db:test-set-cpuload!      newdat cpuload)))
						       ;; (debug:print 0 "newdat=" newdat)
						       newdat)
						     )
						    #f)))
			       ;; (debug:print 0 "newtestdat=" newtestdat)
			       (cond
				((and need-update newtestdat)
				 (set! testdat newtestdat)
				 (set! teststeps    (db:get-compressed-steps test-id work-area: rundir))
				 (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
				 (set! rundir       (db:test-get-rundir testdat))
				 (set! testfullname (db:test-get-fullname testdat))
				 ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n    "))
				 
				 ;; I don't see why this was implemented this way. Please comment it ...
				 ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same
				 ;;     (set! db-mod-time (+ curr-mod-time 1))
				 ;;     (set! db-mod-time curr-mod-time))

				 (if (not (eq? curr-mod-time db-mod-time))
				     (set! db-mod-time curr-mod-time))
				 (set! last-update (current-milliseconds))
				 (set! request-update #f) ;; met the need ...
				 )
				(need-update ;; if this was true and yet there is no data ....
				 (db:test-set-testname! testdat "DEAD OR DELETED TEST")))
			       (if need-update
				   (begin
				     ;; update the gui elements here
				     (for-each 
				      (lambda (key)
					;; (print "Updating " key)
					((hash-table-ref widgets key) testdat))
				      (hash-table-keys widgets))
				     (update-state-status-buttons testdat)))
			       ;; (iup:refresh self)
			       )))
	       (meta-widgets (make-hash-table))
	       (self         #f)
	       (store-label  (lambda (name lbl cmd)
			       (hash-table-set! widgets name 
						(lambda (testdat)
						  (let ((newval (cmd testdat))
							(oldval (iup:attribute lbl "TITLE")))

	       (remove-test (lambda (x)
			      (iup:attribute-set!
			       command-text-box "VALUE"
			       (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
				     " -testpatt " (conc testname "/" (if (equal? item-path "")
									  "%"
									  item-path))
				     " -v ;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
	       (clean-run-execute  (lambda (x)
				     (let ((cmd (conc "xterm -geometry 180x20 -e \""
						      "megatest -remove-runs -target " keystring " :runname " runname
						      " -testpatt " (conc testname "/" (if (equal? item-path "")
											   "%"
											   item-path))
						      ";megatest -target " keystring " :runname " runname 
						      " -runtests " (conc testname "/" (if (equal? item-path "")
											   "%" 
											   item-path))
						      " ;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))
				       (system (conc cmd " &")))))
	       (remove-test (lambda (x)
			      (iup:attribute-set!
			       command-text-box "VALUE"
			       (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
				     " -testpatt " (conc testname "/" (if (equal? item-path "")
									  "%"
									  item-path))
				     " -v ;echo Press any key to continue;bash -c 'read -n 1 -s'\""))
			      )))
	  (cond
	   ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
	   ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
	   (else
	    ;;  (test-set-status! db run-id test-name state status itemdat)
	    (set! self ; 
		  (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"

			       (iup:frame #:title "Actions" 
					  (iup:vbox
					   (iup:hbox 
					    (iup:button "View Log"      #:action viewlog     #:size "80x")
					    (iup:button "Start Xterm"   #:action xterm       #:size "80x")
					    (iup:button "Run Test"      #:action run-test    #:size "80x")
					    (iup:button "Clean Test"    #:action remove-test #:size "80x")
					    (iup:button "CleanRunExecute!"    #:action clean-run-execute #:size "80x")
					    (iup:button "Kill All Jobs" #:action kill-jobs   #:size "80x")
					    (iup:button "Close"         #:action (lambda (x)(exit)) #:size "80x"))
					   (apply 
					    iup:hbox
					    (list command-text-box command-launch-button))))
			       (set-fields-panel test-id testdat)
			       (let ((tabs 
				      (iup:tabs
				       ;; Replace here with matrix
				       (let ((steps-matrix (iup:matrix
							    #:font   "Courier New, -8"
							    #:expand "YES"
							    #:scrollbar "YES"
							    #:numcol 6
							    #:numlin 30
							    #:numcol-visible 6
							    #:numlin-visible 5
							    #:click-cb (lambda (obj lin col status)
									 ;; (if (equal? col 6)
									 (let* ((mtrx-rc (conc lin ":" 6))
										(fname   (iup:attribute obj mtrx-rc))) ;; col))))
									   (if (eq? col 6)
									       (view-a-log fname)
									       (iup:show
										(dashboard-tests:step-run-control 
										 testdat
										 (iup:attribute obj (conc lin ":" 1)) 
										 teststeps))))))))
					 ;; (let loop ((count 0))
					 ;;   (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count))
					 ;;   (if (< count 30)
					 ;;       (loop (+ count 1))))
					 (iup:attribute-set! steps-matrix "0:1" "Step Name")
					 (iup:attribute-set! steps-matrix "0:2" "Start")
					 (iup:attribute-set! steps-matrix "0:3" "End")
					 (iup:attribute-set! steps-matrix "WIDTH3" "50")
					 (iup:attribute-set! steps-matrix "0:4" "Status")
					 (iup:attribute-set! steps-matrix "WIDTH4" "50")
					 (iup:attribute-set! steps-matrix "0:5" "Duration")
					 (iup:attribute-set! steps-matrix "0:6" "Log File")
					 (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
					 ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
					 (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
					 (let ((proc
						(lambda (testdat)
						  (let ((max-row 0))
						  (if (not (null? teststeps))
						      (let loop ((hed    (car teststeps))
								 (tal    (cdr teststeps))
								 (rownum 1)
								 (colnum 1))
							  (if (> rownum max-row)(set! max-row rownum))
							(let ((val     (vector-ref hed (- colnum 1)))
							      (mtrx-rc (conc rownum ":" colnum)))
							  (iup:attribute-set! steps-matrix  mtrx-rc (if val (conc val) ""))
							  (if (< colnum 6)
							      (loop hed tal rownum (+ colnum 1))
							      (if (not (null? tal))
								    (loop (car tal)(cdr tal)(+ rownum 1) 1))))))
						    (if (> max-row 0)
							(begin
							  ;; we are going to speculatively clear rows until we find a row that is already cleared
							  (let loop ((rownum  (+ max-row 1))
								     (colnum  0)
								     (deleted #f))
							    ;; (debug:print-info 0 "cleaning " rownum ":" colnum)
							    (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum))
								   (next-col (if (eq? colnum 6) 1 (+ colnum 1)))
								   (mtrx-rc  (conc rownum ":" colnum))
								   (curr-val (iup:attribute steps-matrix mtrx-rc)))
							      ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val)
							      (if (and (string? curr-val)
								       (not (equal? curr-val "")))
								  (begin
								    (iup:attribute-set! steps-matrix mtrx-rc "")
								    (loop next-row next-col #t))
								  (if (eq? colnum 6) ;; not done, didn't get a full blank row
								      (if deleted (loop next-row next-col #f)) ;; exit on this not met
								      (loop next-row next-col deleted)))))
							  (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))))
					   (hash-table-set! widgets "StepsMatrix" proc)
					   (proc testdat))
					 steps-matrix)
				       ;; populate the Test Data panel
				       (iup:frame
					#:title "Test Data"
					(let ((test-data

											      (db:test-data-get-value    x)
											      (db:test-data-get-expected x)
											      (db:test-data-get-tol      x)
											      (db:test-data-get-status   x)
											      (db:test-data-get-units    x)
											      (db:test-data-get-type     x)
											      (db:test-data-get-comment  x)))
										    (open-run-close db:read-test-data db test-id "%")))
									      "\n")))
							       (if (not (equal? currval newval))
								   (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
					  test-data))
				       ;;(dashboard:run-controls)
				       )))
				 (iup:attribute-set! tabs "TABTITLE0" "Steps")
				 (iup:attribute-set! tabs "TABTITLE1" "Test Data")
				 tabs))))
	    (iup:show self)
	    (iup:callback-set! *tim* "ACTION_CB"
			       (lambda (x)
				 ;; Now start keeping the gui updated from the db
				 (refreshdat) ;; update from the db here
					;(thread-suspend! other-thread)








				 (if *exit-started*
				     (set! *exit-started* 'ok))))))))))

;;======================================================================

(use format)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(use trace)

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))
(declare (uses configf))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
(declare (uses tree))
(declare (uses dcommon))

;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(define help (conc 
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2013

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

(define toplevel #f)
(define dlg      #f)
(define max-test-num 0)
;; (define *keys*   (open-run-close db:get-keys #f))
(define *keys*   (cdb:remote-run db:get-keys #f))
;; (define *keys*   (db:get-keys   *db*))

(define *dbkeys*  (append *keys* (list "runname")))

(define *header*       #f)
(define *allruns*     '())
(define *allruns-by-id* (make-hash-table)) ;; 
(define *runchangerate* (make-hash-table))

(define *buttondat*    (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts*  (make-hash-table))
(define *num-runs*      8)
(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%"))
;; (define *tot-run-count* (db:get-num-runs *db* "%"))

;; Update management
;;
(define *last-update*   (current-seconds))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)
(define *delayed-update* 0)
(define *update-is-running* #f)
(define *update-mutex* (make-mutex))

(define *all-item-test-names* '())
(define *num-tests*     15)
(define *start-run-offset*  0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *status-ignore-hash* (make-hash-table))
(define *state-ignore-hash*  (make-hash-table))

(define *db-file-path* (conc *toppath* "/megatest.db"))

(define *tests-sort-options* (vector (vector "Sort +a" 'testname   "ASC")
				     (vector "Sort -a" 'testname   "DESC")
				     (vector "Sort +t" 'event_time "ASC")
				     (vector "Sort -t" 'event_time "DESC")
				     (vector "Sort +s" 'statestatus "ASC")
				     (vector "Sort -s" 'statestatus "DESC")))

;; Don't forget to adjust the >= below if you add to the sort-options above
(define (next-sort-option)
  (if (>= *tests-sort-reverse* 5)
      (set! *tests-sort-reverse* 0)
      (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1)))
  *tests-sort-reverse*)

(define (get-curr-sort)
  (vector-ref *tests-sort-options* *tests-sort-reverse*))

(define *tests-sort-reverse* 3)
(define *hide-empty-runs* #f)
(define *hide-not-hide* #t) ;; toggle for hide/not hide
(define *hide-not-hide-button* #f)
(define *hide-not-hide-tabs* #f)

(define *current-tab-number* 0)
(define *updaters* (make-hash-table))

(debug:setup)

(define uidat #f)

(define-inline (dboard:uidat-get-keycol  vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol  vec)(vector-ref vec 1))
(define-inline (dboard:uidat-get-header  vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))


(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))

(define (iuplistbox-fill-list lb items #!key (selected-item #f))
  (let ((i 1))


    (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" i))) ;; (number->string i))))
		(set! i (+ i 1)))
	      items)
    ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
    i))

(define (pad-list l n)(append l (make-list (- n (length l)))))

(define (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))))

;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)

  (let* ((referenced-run-ids '())











	 (allruns     (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      *start-run-offset* keypatts))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0)
	 (states      (hash-table-keys *state-ignore-hash*))
	 (statuses    (hash-table-keys *status-ignore-hash*))



	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname


			  'itempath)))
    ;; 
    ;; trim runs to only those that are changing often here

    ;; 
    (for-each (lambda (run)
		(let* ((run-id      (db:get-value-by-header run header "id"))
		       (tests       (mt:get-tests-for-run run-id testnamepatt states statuses
							  not-in: *hide-not-hide*
							  sort-by: sort-by
							  sort-order: sort-order
							  qryvals: 'shortlist))
		       ;; NOTE: bubble-up also sets the global *all-item-test-names*
		       ;; (tests       (bubble-up tmptests priority: bubble-type))
		       (key-vals    (cdb:remote-run db:get-key-vals #f run-id)))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
		  ;; Not sure this is needed?
		  (set! referenced-run-ids (cons run-id referenced-run-ids))
		  (if (> (length tests) maxtests)
		      (set! maxtests (length tests)))
		  (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
			  (not (null? tests)))
		      (let ((dstruct (vector run tests key-vals)))
			;;
			;; compare the tests with the tests in *allruns-by-id* same run-id 
			;; if different then increment value in *runchangerate*
			;;
			(hash-table-set! *allruns-by-id* run-id dstruct)
			(set! result (cons dstruct result))))))
	      runs)





    (set! *header*  header)
    (set! *allruns* result)
    (debug:print-info 6 "*allruns* has " (length *allruns*) " runs")

    maxtests))







(define *collapsed* (make-hash-table))
; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)

(define (toggle-hide lnum) ; fulltestname)
  (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
	 (fulltestname (iup:attribute btn "TITLE"))

	   (vector-set! res 0 (car splst))
	   (if (> (length splst) 1)
	       (vector-set! res 1 (car (string-split (cadr splst) ")"))))
	   res))
       lst))

(define (collapse-rows inlst)
  (let* ((sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath))
	 (newlst      (filter (lambda (x)
				(let* ((tparts    (string-split x "("))
				       (basetname (if (null? tparts) x (car tparts))))
					;(print "x " x " tparts: " tparts " basetname: " basetname)
				  (cond
				   ((string-match blank-line-rx x) #f)
				   ((equal? x basetname) #t)
				   ((hash-table-ref/default *collapsed* basetname #f) 
					;(print "Removing " basetname " from items")
				    #f)
				   (else #t))))
			      inlst))
	 (vlst         (run-item-name->vectors newlst))

	 (vlst2        (bubble-up vlst priority: bubble-type)))






    (map (lambda (x)
	   (if (equal? (vector-ref x 1) "")
	       (vector-ref x 0)
	       (conc (vector-ref x 0) "(" (vector-ref x 1) ")")))
	 vlst2)))
    
(define (update-labels uidat)
  (let* ((rown    0)
	 (keycol  (dboard:uidat-get-keycol uidat))
	 (lftcol  (dboard:uidat-get-lftcol uidat))
	 (numcols (vector-length lftcol))
	 (maxn    (- numcols 1))

				(if (> (length parts) 1)(conc "  " (car (string-split (cadr parts) ")"))) newval))))
	      (vector-set! keycol i newval)
	      (iup:attribute-set! lbl "TITLE" munged-val)))
	(iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0"))
	(if (< i maxn)
	    (loop (+ i 1)))))))

;; 
(define (get-itemized-tests test-dats)
  (let ((tnames '()))
    (for-each (lambda (tdat)
		(let ((tname (vector-ref tdat 0))  ;; (db:test-get-testname tdat))
		      (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat)))
		  (if (not (equal? ipath ""))
		      (if (not (member tname tnames))
			  (set! tnames (append tnames (list tname)))))))
	      test-dats)))

;; Bubble up the top tests to above the items, collect the items underneath
;; all while preserving the sort order from the SQL query as best as possible.
;;
(define (bubble-up test-dats #!key (priority 'itempath))
  (if (null? test-dats)
      test-dats
      (begin
	(let* ((tnames   '())                ;; list of names used to reserve order
	       (tests    (make-hash-table))  ;; hash of lists, used to build as we go
	       (itemized (get-itemized-tests test-dats)))
	  (for-each 
	   (lambda (testdat)
	     (let* ((tname (vector-ref testdat 0))  ;; db:test-get-testname testdat))
		    (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat)))
	       ;;   (seen  (hash-table-ref/default tests tname #f)))
	       (if (not (member tname tnames))
		   (if (or (and (eq? priority 'itempath)
				(not (equal? ipath "")))
			   (and (eq? priority 'testname)
				(equal? ipath ""))
			   (not (member tname itemized)))
		       (set! tnames (append tnames (list tname)))))
	       (if (equal? ipath "")
		   ;; This a top level, prepend it
		   (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '())))
		   ;; This is item, append it
		   (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat))))))
	   test-dats)
	  ;; Set all tests with items 
	  (set! *all-item-test-names* (append (if (null? tnames)
						  '()
						  (filter (lambda (tname)
							    (let ((tlst (hash-table-ref tests tname)))
							      (and (list tlst)
								   (> (length tlst) 1))))
							  tnames))
					      *all-item-test-names*))
	  (let loop ((hed (car tnames))
		     (tal (cdr tnames))
		     (res '()))
	    (let ((newres (append res (hash-table-ref tests hed))))
	      (if (null? tal)
		  newres
		  (loop (car tal)(cdr tal) newres))))))))
      
(define (update-buttons uidat numruns numtests)

  (let* ((runs        (if (> (length *allruns*) numruns)
			  (take-right *allruns* numruns)
			  (pad-list *allruns* numruns)))
	 (lftcol      (dboard:uidat-get-lftcol uidat))
	 (tableheader (dboard:uidat-get-header uidat))
	 (table       (dboard:uidat-get-runsvec uidat))
	 (coln        0))

    (set! *alltestnamelst* '())
    ;; create a concise list of test names
    (for-each
     (lambda (rundat)
       (if (vector? rundat)
	   (let* ((testdat   (vector-ref rundat 1))
		  (testnames (map test:test-get-fullname testdat)))
	     (if (not (and *hide-empty-runs*
			   (null? testnames)))
		 (for-each (lambda (testname)
			     (if (not (member testname *alltestnamelst*))
				 (begin
				   (set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
			   testnames)))))
     runs)

    (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness
    (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*)
					 (drop *alltestnamelst* *start-test-offset*)
					 '())))
			     (append xl (make-list (- *num-tests* (length xl)) ""))))
    (update-labels uidat)
    (for-each
     (lambda (rundat)
       (if (not rundat) ;; handle padded runs
	   ;;           ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration
	   (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3)))
       (let* ((run      (vector-ref rundat 0))
	      (testsdat (vector-ref rundat 1))
	      (key-val-dat (vector-ref rundat 2))
	      (run-id   (db:get-value-by-header run *header* "id"))
	      (key-vals (append key-val-dat
				(list (let ((x (db:get-value-by-header run *header* "runname")))
					(if x x "")))))
	      (run-key  (string-intersperse key-vals "\n")))
	 
	 ;; fill in the run header key values
	 (let ((rown      0)
	       (headercol (vector-ref tableheader coln)))
	   (for-each (lambda (kval)
		       (let* ((labl      (vector-ref headercol rown)))
			 (if (not (equal? kval (iup:attribute labl "TITLE")))
			     (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
			 (set! rown (+ rown 1))))
		     key-vals))
	 
	 ;; For this run now fill in the buttons for each test
	 (let ((rown 0)
	       (columndat  (vector-ref table coln)))
	   (for-each
	    (lambda (testname)
	      (let ((buttondat  (hash-table-ref/default *buttondat* (mkstr coln rown) #f)))
		(if buttondat
		    (let* ((test       (let ((matching (filter 
							(lambda (x)(equal? (test:test-get-fullname x) testname))
							testsdat)))
					 (if (null? matching)
					     (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
					     (car matching))))
			   (testname   (db:test-get-testname  test))
			   (itempath   (db:test-get-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-get-status   test))
			   (teststate  (db:test-get-state    test))
			   ;;(teststart  (db:test-get-event_time test))
			   (runtime    (db:test-get-run_duration test))
			   (buttontxt  (if (equal? teststate "COMPLETED") teststatus teststate))
			   (button     (vector-ref columndat rown))
			   (color      (car (gutils:get-color-for-state-status teststate teststatus)))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
		      (if (not (equal? curr-color color))
			  (iup:attribute-set! button "BGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
			  (iup:attribute-set! button "TITLE"   buttontxt))
		      (vector-set! buttondat 0 run-id)
		      (vector-set! buttondat 1 color)
		      (vector-set! buttondat 2 buttontxt)
		      (vector-set! buttondat 3 test)
		      (vector-set! buttondat 4 run-key)))
		(set! rown (+ rown 1))))
	    *alltestnamelst*))
	 (set! coln (+ coln 1))))
     runs)))

(define (mkstr . x)
  (string-intersperse (map conc x) ","))

(define (set-bg-on-filter)
  (let ((search-changed (not (null? (filter (lambda (key)
					      (not (equal? (hash-table-ref *searchpatts* key) "%")))
					    (hash-table-keys *searchpatts*)))))
	(state-changed  (not (null? (hash-table-keys *state-ignore-hash*))))
	(status-changed (not (null? (hash-table-keys *status-ignore-hash*)))))
    (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR"
			(if (or search-changed
				state-changed
				status-changed)
			    "190 180 190"
			    "190 190 190"
			    ))))

(define (update-search x val)

  (hash-table-set! *searchpatts* x val)
  (set-bg-on-filter))

(define (mark-for-update)
  (set! *last-db-update-time* 0)
  (set! *delayed-update* 1))

;;======================================================================
;; R U N C O N T R O L
;;======================================================================

;; target populating logic
;;  
;; lb            = <vector curr-label-object next-label-object>
;; field         = target field name for this dropdown
;; referent-vals = selected value in the left dropdown
;; targets       = list of targets to use to build the dropdown
;; 
;; each node is chained: key1 -> key2 -> key3
;;
;; must select values from only apropriate targets
;;   a b c
;;   a d e
;;   a b f
;;        a/b => c f
;;
(define (dashboard:populate-target-dropdown lb referent-vals targets) ;;  runconf-targs)
  ;; is the current value in the new list? choose new default if not
  (let* ((remvalues  (map (lambda (row)
			    (common:list-is-sublist referent-vals (vector->list row)))
			  targets))
	 (values     (delete-duplicates (map car (filter list? remvalues))))
	 (sel-valnum (iup:attribute lb "VALUE"))
	 (sel-val    (iup:attribute lb sel-valnum))
	 (val-num    1))
    ;; first check if the current value is in the new list, otherwise replace with 
    ;; first value from values
    (iup:attribute-set! lb "REMOVEITEM" "ALL")
    (for-each (lambda (val)
		;; (iup:attribute-set! lb "APPENDITEM" val)
		(iup:attribute-set! lb (conc val-num) val)
		(if (equal? sel-val val)
		    (iup:attribute-set! lb "VALUE" val-num))
		(set! val-num (+ val-num 1)))
	      values)
    (let ((val (iup:attribute lb "VALUE")))
      (if val
	  val
	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (open-run-close db:get-targets #f))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (all-targets   (append db-targets
				(map (lambda (x)
				       (list->vector
					(take (append (string-split x "/")
						      (make-list (length header) "na"))
					      (length header))))
				     runconf-targs)))
	 (key-listboxes (if key-lbs key-lbs (make-list (length header) #f))))
    (let loop ((key     (car header))
	       (remkeys (cdr header))
	       (refvals '())
	       (indx    0)
	       (lbs     '()))
      (let* ((lb (let ((lb (list-ref key-listboxes indx)))
		   (if lb
		       lb
		       (iup:listbox 
			#:size "45x50" 
			#:fontsize "10"
			#:expand "YES" ;; "VERTICAL"
			;; #:dropdown "YES"
			#:editbox "YES"
			#:action (lambda (obj a b c)
				   (action-proc))
			#:caret_cb (lambda (obj a b c)(action-proc))
			))))
	     ;; loop though all the targets and build the list for this dropdown
	     (selected-value (dashboard:populate-target-dropdown lb refvals all-targets)))
	(if (null? remkeys)
	    ;; return a list of the listbox items and an iup:hbox with the labels and listboxes
	    (let ((listboxes (append lbs (list lb))))
	      (list listboxes
		    (map (lambda (htxt lb)
			   (iup:vbox
			    (iup:label htxt) 
			    lb))
			 header
			 listboxes)))
	    (loop (car remkeys)
		  (cdr remkeys)
		  (append refvals (list selected-value))
		  (+ indx 1)
		  (append lbs (list lb))))))))

;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string 
;; interspersed with commas
;;
(define (dashboard:text-list-toggle-box items proc)
  (let ((alltgls (make-hash-table)))
    (apply iup:vbox
	   (map (lambda (item)
		  (iup:toggle 
		   item
		   #:expand "YES"
		   #:action (lambda (obj tstate)
			      (if (eq? tstate 0)
				  (hash-table-delete! alltgls item)
				  (hash-table-set! alltgls item #t))
			      (let ((all (hash-table-keys alltgls)))
				(proc all)))))
		items))))

;; Extract the various bits of data from *data* and create the command line equivalent that will be displayed
;;
(define (dashboard:update-run-command)
  (let* ((cmd-tb       (dboard:data-get-command-tb *data*))
	 (cmd          (dboard:data-get-command    *data*))
	 (test-patt    (let ((tp (dboard:data-get-test-patts *data*)))
			 (if (equal? tp "") "%" tp)))
	 (states       (dboard:data-get-states     *data*))
	 (statuses     (dboard:data-get-statuses   *data*))
	 (target       (let ((targ-list (dboard:data-get-target     *data*)))
			 (if targ-list (string-intersperse targ-list "/") "no-target-selected")))
	 (run-name     (dboard:data-get-run-name   *data*))
	 (states-str   (if (or (not states)
			       (null? states))
			   ""
			   (conc " :state "  (string-intersperse states ","))))
	 (statuses-str (if (or (not statuses)
			       (null? statuses))
			   ""
			   (conc " :status " (string-intersperse statuses ","))))
	 (full-cmd  "megatest"))
    (case (string->symbol cmd)
      ((runtests)
       (set! full-cmd (conc full-cmd 
			    " -runtests "
			    test-patt
			    " -target "
			    target
			    " :runname "
			    run-name
			    )))
      ((remove-runs)
       (set! full-cmd (conc full-cmd
			    " -remove-runs :runname "
			    run-name
			    " -target " 
			    target
			    " -testpatt "
			    test-patt
			    states-str
			    statuses-str
			    )))
      (else (set! full-cmd " no valid command ")))
    (iup:attribute-set! cmd-tb "VALUE" full-cmd)))

;; Display the tests as rows of boxes on the test/task pane
;;
(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)
  (canvas-clear! cnv)
  (canvas-font-set! cnv "Helvetica, -10")
  (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
	       ((originx originy)             (canvas-origin cnv)))
      ;; (print "originx: " originx " originy: " originy)
      ;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
      (if (hash-table-ref/default tests-draw-state 'first-time #t)
	  (begin
	    (hash-table-set! tests-draw-state 'first-time #f)
	    (hash-table-set! tests-draw-state 'scalef 8)
	    (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
	    (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
	    ;; set these 
	    (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj))))
	    (hash-table-set! tests-draw-state 'test-browse-yoffset 20))) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
      (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
	     (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	     (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	     (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;;  (- xadj 1))))
	     (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
	     (boxw   90)
	     (boxh   25)
	     (gapx   20)
	     (gapy   30)
	     (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	     (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
	;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames)))
		   (llx xtorig)
		   (lly ytorig)
		   (urx (+ xtorig boxw))
		   (ury (+ ytorig boxh)))
	  ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	  (canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")"))
	  (canvas-rectangle! cnv llx urx lly ury)
	  (if (hash-table-ref/default selected-tests hed #f)
	      (canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))
	  (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly))) ;; NB// Swap ury and lly
	  (if (not (null? tal))
	      ;; leave a column of space to the right to list items
	      (let ((have-room 
		     (if #t ;; put "auto" here where some form of auto rearanging can be done
			 (> (* 3 (+ boxw gapx)) (- urx xtorig))
			 (< urx (- sizex boxw gapx boxw)))))  ;; is there room for another column?
		(loop (car tal)
		      (cdr tal)
		      (if have-room (+ llx boxw gapx) xtorig) ;; have room, 
		      (if have-room lly (+ lly boxh gapy))
		      (if have-room (+ urx boxw gapx) (+ xtorig boxw))
		      (if have-room ury (+ ury boxh gapy)))))))))

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-controls)
  (let* ((targets       (make-hash-table))
	 (test-records  (make-hash-table))
	 (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '()))
	 (test-names    (hash-table-keys all-tests-registry))
	 (sorted-testnames #f)
	 (action        "-runtests")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 (key-listboxes #f)
	 (updater-for-runs #f)
	 (update-keyvals (lambda ()
			   (let ((targ (map (lambda (x)
					      (iup:attribute x "VALUE"))
					    (car (dashboard:update-target-selector key-listboxes)))))
			     (dboard:data-set-target! *data* targ)
			     (if updater-for-runs (updater-for-runs))
			     (dashboard:update-run-command))))
	 (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    (hash-table-set! tests-draw-state 'scalef 8)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to *keys*, *dbkeys* for keys
    (iup:vbox
     ;; The command line display/exectution control
     (iup:frame
      #:title "Command to be exectuted"
      (iup:hbox
       (iup:label "Run on" #:size "40x")
       (iup:radio 
	(iup:hbox
	 (iup:toggle "Local" #:size "40x")
	 (iup:toggle "Server" #:size "40x")))
       (let ((tb (iup:textbox 
		  #:value "megatest "
		  #:expand "HORIZONTAL"
		  #:readonly "YES"
		  #:font "Courier New, -12"
		  )))
	 (dboard:data-set-command-tb! *data* tb)
	 tb)
       (iup:button "Execute" #:size "50x"
		   #:action (lambda (obj)
			      (let ((cmd (conc "xterm -geometry 180x20 -e \""
					       (iup:attribute (dboard:data-get-command-tb *data*) "VALUE")
					       ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
				(system cmd))))))

     (iup:split
      #:orientation "HORIZONTAL"
      
      (iup:split
       #:value 300

       ;; Target, testpatt, state and status input boxes
       ;;
       (iup:vbox
	;; Command to run
	(iup:frame
	 #:title "Set the action to take"
	 (iup:hbox
	  ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER")
	  (let* ((cmds-list '("runtests" "remove-runs" "set-state-status" "lock-runs" "unlock-runs"))
		 (lb         (iup:listbox #:expand "HORIZONTAL"
					  #:dropdown "YES"
					  #:action (lambda (obj val index lbstate)
						     ;; (print obj " " val " " index " " lbstate)
						     (dboard:data-set-command! *data* val)
						     (dashboard:update-run-command))))
		 (default-cmd (car cmds-list)))
	    (iuplistbox-fill-list lb cmds-list selected-item: default-cmd)
	    (dboard:data-set-command! *data* default-cmd)
	    lb)))

	(iup:frame
	 #:title "Runname"
	 (let* ((default-run-name (conc "ww" (seconds->work-week/day (current-seconds))))
		(tb (iup:textbox #:expand "HORIZONTAL"
				 #:action (lambda (obj val txt)
					    ;; (print "obj: " obj " val: " val " unk: " unk)
					    (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE"))
					    (dashboard:update-run-command))
				 #:value default-run-name))
		(lb (iup:listbox #:expand "HORIZONTAL"
				 #:dropdown "YES"
				 #:action (lambda (obj val index lbstate)
					    (iup:attribute-set! tb "VALUE" val)
					    (dboard:data-set-run-name! *data* val)
					    (dashboard:update-run-command))))
		(refresh-runs-list (lambda ()
				     (let* ((target        (dboard:data-get-target-string *data*))
					    (runs-for-targ (mt:get-runs-by-patt *keys* "%" target))
					    (runs-header   (vector-ref runs-for-targ 0))
					    (runs-dat      (vector-ref runs-for-targ 1))
					    (run-names     (cons default-run-name 
								 (map (lambda (x)
									(db:get-value-by-header x runs-header "runname"))
								      runs-dat))))
				       (iup:attribute-set! lb "REMOVEITEM" "ALL")
				       (iuplistbox-fill-list lb run-names selected-item: default-run-name)))))
	   (set! updater-for-runs refresh-runs-list)
	   (refresh-runs-list)
	   (dboard:data-set-run-name! *data* default-run-name)
	   (iup:hbox
	    tb
	    lb)))

	(iup:frame
	 #:title "SELECTORS"
	 (iup:vbox
	  ;; Text box for test patterns
	  (iup:frame
	   #:title "Test patterns (one per line)"
	   (let ((tb (iup:textbox #:action (lambda (val a b)
					     (dboard:data-set-test-patts!
					      *data*
					      (dboard:lines->test-patt b))
					     (dashboard:update-run-command))
				  #:value (dboard:test-patt->lines
					   (dboard:data-get-test-patts *data*))
				  #:expand "YES"
				  #:size "x50"
				  #:multiline "YES")))
	     (set! test-patterns-textbox tb)
	     tb))
	  (iup:frame
	   #:title "Target"
	   ;; Target selectors
	   (apply iup:hbox
		  (let* ((dat      (dashboard:update-target-selector key-listboxes action-proc: update-keyvals))
			 (key-lb   (car dat))
			 (combos   (cadr dat)))
		    (set! key-listboxes key-lb)
		    combos)))
	  (iup:hbox
	   ;; Text box for STATES
	   (iup:frame
	    #:title "States"
	    (dashboard:text-list-toggle-box 
	     ;; Move these definitions to common and find the other useages and replace!
	     *common:std-states* ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
	     (lambda (all)
	       (dboard:data-set-states! *data* all)
	       (dashboard:update-run-command))))
	   ;; Text box for STATES
	   (iup:frame
	    #:title "Statuses"
	    (dashboard:text-list-toggle-box 
	     *common:std-statuses* ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
	     (lambda (all)
	       (dboard:data-set-statuses! *data* all)
	       (dashboard:update-run-command))))))))
      
       (iup:frame
	#:title "Tests and Tasks"
	(let* ((updater #f)
	       (last-xadj 0)
	       (last-yadj 0)
	       (canvas-obj   
	(iup:canvas #:action (make-canvas-action
			      (lambda (cnv xadj yadj)
				(if (not updater)
				    (set! updater (lambda (xadj yadj)
						    ;; (print "cnv: " cnv " x: " x " y: " y)
						    (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames))))
				(updater xadj yadj)
				(set! last-xadj xadj)
				(set! last-yadj yadj)))
		    ;; Following doesn't work 
		    ;; #:wheel-cb (make-canvas-action
		    ;;           (lambda (cnv xadj yadj)
		    ;;    	 ;; (print "cnv: " cnv " x: " x " y: " y)
		    ;;    	 (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)))
		    ;; #:size "50x50"
		    #:expand "YES"
		    #:scrollbar "YES"
		    #:posx "0.5"
		    #:posy "0.5"
		    #:button-cb (lambda (obj btn pressed x y status)
				  ;; (print "obj: " obj)
				  (let ((tests-info     (hash-table-ref tests-draw-state  'tests-info))
					(selected-tests (hash-table-ref tests-draw-state  'selected-tests)))
				    ;; (print "x\ty\tllx\tlly\turx\tury")
				    (for-each (lambda (test-name)
						(let* ((rec-coords (hash-table-ref tests-info test-name))
						       (llx        (list-ref rec-coords 0))
						       (urx        (list-ref rec-coords 1))
						       (lly        (list-ref rec-coords 2))
						       (ury        (list-ref rec-coords 3)))
						  ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " "
						  (if (and (eq? pressed 1)
							   (> x llx)
							   (> y lly)
							   (< x urx)
							   (< y ury))
						      (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))))
							(let* ((selected     (not (member test-name patterns)))
							       (newpatt-list (if selected
										 (cons test-name patterns)
										 (delete test-name patterns)))
							       (newpatt      (string-intersperse newpatt-list "\n")))
							  ;; (if cnv-obj
							  ;;    (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames))
							  (iup:attribute-set! obj "REDRAW" "ALL")
							  (hash-table-set! selected-tests test-name selected)
							  (iup:attribute-set! test-patterns-textbox "VALUE" newpatt)
							  (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt))
							  (dashboard:update-run-command)
							  (if updater (updater last-xadj last-yadj)))))))
					      (hash-table-keys tests-info)))))))
	  canvas-obj)))
      ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status))
      
      (iup:frame
       #:title "Logs" ;; To be replaced with tabs
       (let ((logs-tb (iup:textbox #:expand "YES"
				   #:multiline "YES")))
	 (dboard:data-set-logs-textbox! *data* logs-tb)
	 logs-tb))))))


;; (trace dashboard:populate-target-dropdown
;;        common:list-is-sublist)
;; 
;;       ;; key1 key2 key3 ...
;;       ;; target entry (wild cards allowed)
;;       
;;       ;; The action
;;       (iup:hbox
;;        ;; label Action | action selector
;;        ))
;;      ;; Test/items selector
;;      (iup:hbox
;;       ;; tests
;;       ;; items
;;       ))
;;     ;; The command line
;;     (iup:hbox
;;      ;; commandline entry
;;      ;; GO button
;;      )
;;     ;; The command log monitor
;;     (iup:tabs
;;      ;; log monitor
;;      )))

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary)
  (let ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f 'return-string)))
    (iup:vbox
     (iup:split
      ;; #:value 500
      (iup:frame 
       #:title "General Info"
       (iup:hbox 
	(dcommon:keys-matrix rawconfig)
	(dcommon:general-info)
	))
      (iup:frame
       #:title "Server"
       (dcommon:servers-table)))
     (iup:frame 
      #:title "Megatest config settings"
      (iup:hbox
       (dcommon:section-matrix rawconfig "setup" "Varname" "Value")
       (iup:vbox
	(dcommon:section-matrix rawconfig "server" "Varname" "Value")
	;; (iup:frame
	;; #:title "Disks Areas"
	(dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
     (iup:frame
      #:title "Run statistics"
      (dcommon:run-stats)))))

;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time

(define (tree-path->run-id path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f)
      #f))

(define dashboard:update-run-summary-tab #f)

;; (define (tests window-id)
(define (dashboard:one-run)
  (let* ((tb      (iup:treebox
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
		   #:addexpanded "NO"
		   #:selection-cb
		   (lambda (obj id state)
		     ;; (print "obj: " obj ", id: " id ", state: " state)
		     (let* ((run-path (tree:node->path obj id))
			    (run-id   (tree-path->run-id (cdr run-path))))
		       (if run-id
			   (begin
			     (dboard:data-set-curr-run-id! *data* run-id)
			     (dashboard:update-run-summary-tab)))
		       ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
		       ))))
	 (run-matrix (iup:matrix
		      #:expand "YES"))
	 (updater  (lambda ()
		     (let* ((runs-dat     (mt:get-runs-by-patt *keys* "%" #f))
			    (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
			    (run-id       (dboard:data-get-curr-run-id *data*))
			    (tests-dat    (let ((tdat (mt:get-tests-for-run run-id 
									    (hash-table-ref/default *searchpatts* "test-name" "%/%")
									    (hash-table-keys *state-ignore-hash*) ;; '()
									    (hash-table-keys *status-ignore-hash*) ;; '()
									    not-in: *hide-not-hide*
									    qryvals: "id,testname,item_path,state,status"))) ;; get 'em all
					    (sort tdat (lambda (a b)
							 (let* ((aval (vector-ref a 2))
								(bval (vector-ref b 2))
								(anum (string->number aval))
								(bnum (string->number bval)))
							   (if (and anum bnum)
							       (< anum bnum)
							       (string<= aval bval)))))))
			    (tests-mindat (dcommon:minimize-test-data tests-dat))
			    (indices      (common:sparse-list-generate-index tests-mindat)) ;;  proc: set-cell))
			    (row-indices  (cadr indices))
			    (col-indices  (car indices))
			    (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
			    (max-col      (if (null? col-indices) 1 (common:max (map cadr col-indices))))
			    (max-visible  (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window
			    (numrows      1)
			    (numcols      1)
			    (changed      #f)
			    (runs-hash    (let ((ht (make-hash-table)))
					    (for-each (lambda (run)
							(hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
						      (vector-ref runs-dat 1))
					    ht))
			    (run-ids      (sort (filter number? (hash-table-keys runs-hash))
						(lambda (a b)
						  (let* ((record-a (hash-table-ref runs-hash a))
							 (record-b (hash-table-ref runs-hash b))
							 (time-a   (db:get-value-by-header record-a runs-header "event_time"))
							 (time-b   (db:get-value-by-header record-b runs-header "event_time")))
						    (< time-a time-b))))))
		       
		       ;; (iup:attribute-set! tb "VALUE" "0")
		       ;; (iup:attribute-set! tb "NAME" "Runs")
		       ;; Update the runs tree
		       (for-each (lambda (run-id)
				   (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
					  (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
							   *keys*))
					  (run-name   (db:get-value-by-header run-record runs-header "runname"))
					  (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
					  (run-path   (append key-vals (list run-name)))
					  (existing   (tree:find-node tb run-path)))
				     (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f))
					 (begin
					   (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path)
					   ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
					   ;;    		 (conc rownum ":" colnum) col-name)
					   ;; (hash-table-set! runid-to-col run-id (list colnum run-record))
					   ;; Here we update the tests treebox and tree keys
					   (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
							  userdata: (conc "run-id: " run-id))
					   (hash-table-set! (dboard:data-get-path-run-ids *data*) run-path run-id)
					   ;; (set! colnum (+ colnum 1))
					   ))))
				 run-ids)
		       (iup:attribute-set! run-matrix "CLEARVALUE" "CONTENTS")
		       (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
		       (iup:attribute-set! run-matrix "NUMCOL" max-col )
		       (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
		       ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col)
		       ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))
		       
		       ;; Row labels
		       (for-each (lambda (ind)
				   (let* ((name (car ind))
					  (num  (cadr ind))
					  (key  (conc num ":0")))
				     (if (not (equal? (iup:attribute run-matrix key) name))
					 (begin
					   (set! changed #t)
					   (iup:attribute-set! run-matrix key name)))))
				 row-indices)
		       
		       ;; Col labels
		       (for-each (lambda (ind)
				   (let* ((name (car ind))
					  (num  (cadr ind))
					  (key  (conc "0:" num)))
				     (if (not (equal? (iup:attribute run-matrix key) name))
					 (begin
					   (set! changed #t)
					   (iup:attribute-set! run-matrix key name)
					   (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))
				 col-indices)
		       
		       ;; Cell contents
		       (for-each (lambda (entry)
				   (let* ((row-name  (cadr entry))
					  (col-name  (car entry))
					  (valuedat  (caddr entry))
					  (test-id   (list-ref valuedat 0))
					  (test-name row-name) ;; (list-ref valuedat 1))
					  (item-path col-name) ;; (list-ref valuedat 2))
					  (state     (list-ref valuedat 1))
					  (status    (list-ref valuedat 2))
					  (value     (gutils:get-color-for-state-status state status))
					  (row-num   (cadr (assoc row-name row-indices)))
					  (col-num   (cadr (assoc col-name col-indices)))
					  (key       (conc row-num ":" col-num)))
				     (if (not (equal? (iup:attribute run-matrix key) (cadr value)))
					 (begin
					   (set! changed #t)
					   (iup:attribute-set! run-matrix key (cadr value))
					   (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
				 tests-mindat)
		       (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))
    (set! dashboard:update-run-summary-tab updater)
    (dboard:data-set-runs-tree! *data* tb)
    (iup:split
     tb
     run-matrix)))

;;======================================================================
;; R U N S 
;;======================================================================

(define (make-dashboard-buttons nruns ntests keynames)
  (let* ((nkeys   (length keynames))
	 (runsvec (make-vector nruns))
	 (header  (make-vector nruns))
	 (lftcol  (make-vector ntests))
	 (keycol  (make-vector ntests))

	      ;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
	      ;;  	   #:action (lambda (obj unk val)
	      ;;  		      (mark-for-update)
	      ;;  		      (update-search "item-name" val))
	      ))
	    (iup:vbox
	     (iup:hbox
	      (iup:button "Sort -t"   #:action (lambda (obj)
						 (next-sort-option)
						 (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
						 (mark-for-update)))
	      (iup:button "HideEmpty" #:action (lambda (obj)
						 (set! *hide-empty-runs* (not *hide-empty-runs*))
						 (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE"))
						 (mark-for-update)))
	      (let ((hideit (iup:button "HideTests" #:action (lambda (obj)
							       (set! *hide-not-hide* (not *hide-not-hide*))
							       (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
							       (mark-for-update)))))
		(set! *hide-not-hide-button* hideit)
		hideit))
	     (iup:hbox
	      (iup:button "Quit"      #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit)))
	      (iup:button "Refresh"   #:action (lambda (obj)
						 (mark-for-update)))
	      (iup:button "Collapse"  #:action (lambda (obj)
						 (let ((myname (iup:attribute obj "TITLE")))
						   (if (equal? myname "Collapse")
						       (begin
							 (for-each (lambda (tname)

								     (hash-table-set! *collapsed* tname #t))
								   *all-item-test-names*)
							 (iup:attribute-set! obj "TITLE" "Expand"))
						       (begin
							 (for-each (lambda (tname)
								     (hash-table-delete! *collapsed* tname))
								   (hash-table-keys *collapsed*))
							 (iup:attribute-set! obj "TITLE" "Collapse"))))
						 (mark-for-update))))))
	   (iup:frame 
	    #:title "state/status filter"
	    (iup:vbox
	     (apply 
	      iup:hbox
	      (map (lambda (status)
		     (iup:toggle status  #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *status-ignore-hash* status #t)
							  (hash-table-delete! *status-ignore-hash* status))
						      (set-bg-on-filter))))
		   *common:std-statuses*)) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
	     (apply 
	      iup:hbox
	      (map (lambda (state)
		     (iup:toggle state   #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *state-ignore-hash* state #t)
							  (hash-table-delete! *state-ignore-hash* state))
						      (set-bg-on-filter))))
		   *common:std-states*)) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
	     (iup:valuator #:valuechanged_cb (lambda (obj)
					       (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
						     (oldmax   (string->number (iup:attribute obj "MAX")))
						     (maxruns  *tot-run-count*))
						 (set! *start-run-offset* val)
						 (mark-for-update)
						 (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
						 (iup:attribute-set! obj "MAX" (* maxruns 10))))
			   #:expand "HORIZONTAL"
			   #:max (* 10 (length *allruns*))
			   #:min 0
			   #:step 0.01)))
					;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1))))
					;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0))))
	   )
	  )
    
    ;; create the left most column for the run key names and the test names 
    (set! lftlst (list (iup:hbox
			(iup:label) ;; (iup:valuator)
			(apply iup:vbox 
			       (map (lambda (x)		
				      (let ((res (iup:hbox #:expand "HORIZONTAL"
							   (iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL")
							   (iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL"
									#:action (lambda (obj unk val)
										   (mark-for-update)
										   (update-search x val))))))
					(set! i (+ i 1))
					res))
				    keynames)))))
    (let loop ((testnum  0)
	       (res      '()))
      (cond
       ((>= testnum ntests)
	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst (append lftlst (list (iup:hbox  #:expand "HORIZONTAL"
						     (iup:valuator #:valuechanged_cb (lambda (obj)
										       (let ((val (string->number (iup:attribute obj "VALUE")))
											     (oldmax  (string->number (iup:attribute obj "MAX")))
											     (newmax  (* 10 (length *alltestnamelst*))))
											 (set! *please-update-buttons* #t)
											 (set! *start-test-offset* (inexact->exact (round (/ val 10))))
											 (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax)
											 (if (< val 10)
											     (iup:attribute-set! obj "MAX" newmax))
											 ))
								   #:expand "VERTICAL" 
								   #:orientation "VERTICAL"
								   #:min 0
								   #:step 0.01)
						     (apply iup:vbox (reverse res)))))))
       (else
	(let ((labl  (iup:button "" 
				 #:flat "YES" 
				 #:alignment "ALEFT"
					; #:image img1
					; #:impress img2
				 #:size "x15"
				 #:expand "HORIZONTAL"
				 #:fontsize "10"
				 #:action (lambda (obj)
					    (mark-for-update)
					    (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE"))))
	  (vector-set! lftcol testnum labl)

				       #:expand "HORIZONTAL"
				       #:fontsize "10" 
				       #:action (lambda (x)
						  (let* ((toolpath (car (argv)))
							 (buttndat (hash-table-ref *buttondat* button-key))
							 (test-id  (db:test-get-id (vector-ref buttndat 3)))
							 (cmd  (conc toolpath " -test " test-id "&")))
					;(print "Launching " cmd)
						    (system cmd))))))
	  (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) 
	  (vector-set! testvec testnum butn)
	  (loop runnum (+ testnum 1) testvec (cons butn res))))))
    ;; now assemble the hdrlst and bdylst and kick off the dialog
    (iup:show
     (iup:dialog 
      #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
      #:menu (dcommon:main-menu)
      (let* ((runs-view (iup:vbox
			 (apply iup:hbox 
				(cons (apply iup:vbox lftlst)
				      (list 
				       (iup:vbox
					;; the header
					(apply iup:hbox (reverse hdrlst))
					(apply iup:hbox (reverse bdylst))))))
			 controls))
	     (tabs (iup:tabs
		    #:tabchangepos-cb (lambda (obj curr prev)
					(set! *please-update-buttons* #t)
					(set! *current-tab-number* curr))
		    (dashboard:summary)
		    runs-view
		    (dashboard:one-run)
		    (dashboard:run-controls)
		    )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Summary")
	(iup:attribute-set! tabs "TABTITLE1" "Runs")
	(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE3" "Run Control")
	(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	(set! *hide-not-hide-tabs* tabs)
	tabs)))
    (vector keycol lftcol header runsvec)))

(if (or (args:get-arg "-rows")
	(get-environment-variable "DASHBOARDROWS" ))
    (begin
      (set! *num-tests* (string->number (or (args:get-arg "-rows")
					    (get-environment-variable "DASHBOARDROWS"))))
      (update-rundat "%" *num-runs* "%/%" '()))
    (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%/%" '()) 8) 20)))

(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))
(define *last-recalc-ended-time* 0)

(define (dashboard:been-changed)
  (> (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*))

(define (dashboard:set-db-update-time)
  (set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db"))))

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
	   (> modtime last-db-update-time)
	   (> (current-seconds)(+ last-db-update-time 1)))))

(define *monitor-db-path* (conc *toppath* "/monitor.db"))
(define *last-monitor-update-time* 0)

;; Force creation of the db in case it isn't already there.
(let ((db (tasks:open-db)))
  (sqlite3:finalize! db))

(define (dashboard:run-update x)
  (let* ((modtime         (file-modification-time *db-file-path*))
	 (monitor-modtime (file-modification-time *monitor-db-path*))
	 (run-update-time (current-seconds))
	 (recalc          (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
    (if (and (eq? *current-tab-number* 0)
	     (> monitor-modtime *last-monitor-update-time*))
	(begin
	  (set! *last-monitor-update-time* monitor-modtime)
	  (if dashboard:update-servers-table (dashboard:update-servers-table))))
    (if recalc
	(begin	
	  (case *current-tab-number* 
	    ((0) 
	     (if dashboard:update-summary-tab (dashboard:update-summary-tab)))
	    ((1) ;; The runs table is active
	     (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs*
			    (hash-table-ref/default *searchpatts* "test-name" "%/%")
			    ;; (hash-table-ref/default *searchpatts* "item-name" "%")
			    (let ((res '()))
			      (for-each (lambda (key)
					  (if (not (equal? key "runname"))
					      (let ((val (hash-table-ref/default *searchpatts* key #f)))
						(if val (set! res (cons (list key val) res))))))
					*dbkeys*)
			      res))
	     (update-buttons uidat *num-runs* *num-tests*))
	    ((2)
	     (dashboard:update-run-summary-tab))
	    (else
	     (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f)))
	       (if updater (updater)))))
	  (set! *please-update-buttons* #f)
	  (set! *last-db-update-time* modtime)
	  (set! *last-update* run-update-time)
	  (set! *last-recalc-ended-time* (current-milliseconds))))))

;;======================================================================
;; The heavy lifting starts here
;;======================================================================

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(cond 
 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
	  (lambda (x)
	    (on-exit (lambda ()
		       (if *db* (sqlite3:finalize! *db*))))
	    (cdb:remote-run examine-run *db* runid)))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test")
  (let ((testid (string->number (args:get-arg "-test"))))
    (if (and (number? testid)
	     (>= testid 0))
	(examine-test testid)
	(begin

	  (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor *db*))
 (else
  (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
  (iup:callback-set! *tim*
		     "ACTION_CB"
		     (lambda (x)
		       (let ((update-is-running #f))
			 (mutex-lock! *update-mutex*)
			 (set! update-is-running *update-is-running*)
			 (if (not update-is-running)
			     (set! *update-is-running* #t))
			 (mutex-unlock! *update-mutex*)
			 (if (not update-is-running)
			   (begin
			     (dashboard:run-update x)
			     (mutex-lock! *update-mutex*)
			     (set! *update-is-running* #f)
			     (mutex-unlock! *update-mutex*))))
		       1))))

(iup:main-loop)

;;======================================================================
;; Copyright 2006-2013, 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.

(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
(declare (uses client))
(declare (uses mt))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

;; timestamp type (val1 val2 ...)

	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					   (string->number (args:get-arg "-override-timeout"))
					   136000)))) ;; 136000))) ;; 136000 = 2.2 minutes
    (if (and dbexists
	     (not write-access))
	(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
    (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv))
    (if write-access (sqlite3:set-busy-handler! db handler))
    (if (not dbexists)
	(db:initialize db))
    ;; Moving db:set-sync to a call in run.scm - it is a persistent value and only needs to be set once
    ;; (db:set-sync db)
    db))

;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling  proc idb . params)
  (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (if (or *db-write-access*
	  (not (member proc *db:all-write-procs*)))
      (let* ((db   (cond
		    ((sqlite3:database? idb) idb)
		    ((not idb)               (open-db))
		    ((procedure? idb)       (idb))
		    (else   	            (open-db))))
	     (res #f))
	(set! res (apply proc db params))
	(if (not idb)(sqlite3:finalize! db))
	(debug:print-info 11 "open-run-close-no-exception-handling END" )
	res)
      #f))

(define (open-run-close-exception-handling proc idb . params)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
     (debug:print 0 "  " ((condition-property-accessor 'exn 'message) exn))
     (print-call-chain)
     (thread-sleep! (random 120))
     (debug:print-info 0 "trying db call one more time....")
     (apply open-run-close-no-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

	  (set! *last-global-delta-printed* *global-delta*)))
    (debug:print-info 11 "open-run-close-measure END" )
    res))

(define (db:initialize db)
  (debug:print-info 11 "db:initialize START")
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys)))
    (for-each (lambda (key)
		(let ((keyn key))
		  (if (member (string-downcase keyn)
			      (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
				    "pass_count"))
		      (begin
			(print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table")
			(system (conc "rm -f " dbpath))
			(exit 1)))))
	      keys)
    ;; (sqlite3:execute db "PRAGMA synchronous = OFF;")
    (db:set-sync db)
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
    (for-each (lambda (key)
		(sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
	      keys)
    (sqlite3:execute db (conc 
			 "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " 
			 fieldstr (if havekeys "," "")
			 "runname TEXT,"
			 "state TEXT DEFAULT '',"
			 "status TEXT DEFAULT '',"

;; Create the sqlite db for the individual test(s)
(define (open-test-db work-area) 
  (debug:print-info 11 "open-test-db " work-area)
  (if (and work-area 
	   (directory? work-area)
	   (file-read-access? work-area))
      (let* ((dbpath    (conc work-area "/testdat.db"))
	     (tdb-writeable (file-write-access? dbpath))
	     (dbexists  (file-exists? dbpath))
	     (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					       (string->number (args:get-arg "-override-timeout"))
					       136000))))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
			((condition-property-accessor 'exn 'message) exn))
	   (set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access 
	 (set! db (sqlite3:open-database dbpath)))
	(if *db-write-access* (sqlite3:set-busy-handler! db handler))
	(if (not dbexists)
	    (begin
	      (sqlite3:execute db "PRAGMA synchronous = FULL;")
	      (debug:print-info 11 "Initialized test database " dbpath)
	      (db:testdb-initialize db)))
	;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	(debug:print-info 11 "open-test-db END (sucessful)" work-area)

    (if (not dbexists)
	(begin
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")
	  (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))))
    db))

(define (db:log-local-event . loglst)
  (let ((logline (apply conc loglst)))
    ;; (pwd     (current-directory))
    ;; (cmdline (string-intersperse (argv) " "))
    ;; (pid     (current-process-id)))
    (db:log-event logline)))

(define (db:log-event logline)
  (let ((db (open-logging-db)))
    (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
		     logline
		     (current-directory)
		     (string-intersperse (argv) " ")
		     (current-process-id))
    (sqlite3:finalize! db)
    logline))

;;======================================================================
;; TODO:
;;   put deltas into an assoc list with version numbers
;;   apply all from last to current

       (db:set-var db "MEGATEST_VERSION" 1.36)
       (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';"))
      ((< mver 1.37)
       (db:set-var db "MEGATEST_VERSION" 1.37)
       (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) 
      ((< mver megatest-version)
       (db:set-var db "MEGATEST_VERSION" megatest-version))))))

;;======================================================================
;; M A I N T E N A N C E
;;======================================================================

;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCED'));


(define (db:find-and-mark-incomplete db #!key (ovr-deadtime #f))
  (let* ((incompleted '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200)) ;; two hours
	 (run-ids      (db:get-run-ids db))) ;; iterate over runs to divy up the calls
    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
    (for-each
     (lambda (run-id)

       ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
       ;;
       ;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns.
       ;;                   The testdat.db file must be consulted.
       ;;
       ;; HOWEVER: this code in run:test seems to work fine
       ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
       ;;                     (db:test-get-run_duration testdat)))
       ;;                    600) 
       (sqlite3:for-each-row 
	(lambda (test-id)
	  (set! incompleted (cons test-id incompleted)))
	db
	"SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('RUNNING','REMOTEHOSTSTART');"
	run-id deadtime)

       ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
       ;;
       (sqlite3:for-each-row
	(lambda (test-id)
	  (set! incompleted (cons test-id incompleted)))
	db
	"SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('LAUNCHED');"
	run-id (* 60 60 24)))
     run-ids)
       
    ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
    ;;
    (if (> (length incompleted) 0)
	(begin
	  (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc incompleted) ", ") " as INCOMPLETE")
	  (sqlite3:execute 
	   db
	   (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" 
		 (string-intersperse (map conc incompleted) ",")
		 ");"))))))
		     
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
(define (db:clean-up db)
  (let ((count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
	(statements
	 (map (lambda (stmt)
		(sqlite3:prepare db stmt))
	      (list
	       ;; delete all tests that belong to runs that are 'deleted'
	       "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');"
	       ;; delete all tests that are 'DELETED'
	       "DELETE FROM tests WHERE state='DELETED';"
	       ;; delete all tests that have no run
	       "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);"
	       ;; delete all runs that are state='deleted'
	       "DELETE FROM runs WHERE state='deleted';"
	       ;; delete empty runs
	       "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);"
	       ))))
    (sqlite3:with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count before clean: " tot))
			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    (db:find-and-mark-incomplete db)
    (sqlite3:execute db "VACUUM;")))

;;======================================================================
;; meta get and set vars
;;======================================================================

;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*

  (debug:print-info 11 "db:set-var END " var " " val))

(define (db:del-var db var)
  (debug:print-info 11 "db:del-var START " var)
  (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)
  (debug:print-info 11 "db:del-var END " var))

;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change

;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?

(define (db:get-keys db)
  (if *db-keys* *db-keys* 
      (let ((res '()))

	(sqlite3:for-each-row 
	 (lambda (key)
	   (set! res (cons key res)))
	 db
	 "SELECT fieldname FROM keys ORDER BY id DESC;")
	(set! *db-keys* res)

	res)))

;; 
(define (db:get-value-by-header row header field)
  (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field)
  (if (null? header) #f
      (let loop ((hed (car header))
		 (tal (cdr header))
		 (n   0))
	(if (equal? hed field)

(define (db:get-run-key-val db run-id key)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     db 
     (conc "SELECT " key " FROM runs WHERE id=?;")
     run-id)
    res))

;; keys list to key1,key2,key3 ...
(define (runs:get-std-run-fields keys remfields)
  (let* ((header    (append keys remfields))

	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (list keystr header)))

;; make a query (fieldname like 'patt1' OR fieldname 
(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
  (let ((patts (if (string? pattstr)
		   (string-split pattstr ",")
		   '("%"))))
    (string-intersperse (map (lambda (patt)
			       (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
				 (conc fieldname " " wildtype " '" patt "'")))
			     (if (null? patts)
				 '("")
				 patts))
			comparator)))


;; register a test run with the db
(define (db:register-run db keyvals runname state status user)
  (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user)
  (let* ((keys      (map car keyvals))
	 (keystr    (keys->keystr keys))	 
	 (comma     (if (> (length keys) 0) "," ""))
	 (andstr    (if (> (length keys) 0) " AND " ""))
	 (valslots  (keys->valslots keys)) ;; ?,?,? ...

	 (allvals   (append (list runname state status user) (map cadr keyvals)))
	 (qryvals   (append (list runname) (map cadr keyvals)))
	 (key=?str  (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
    (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
    (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
	(let ((res #f))
	  (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
		 allvals)
	  (apply sqlite3:for-each-row 
		 (lambda (id)
		   (set! res id))
		 db
		 (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
					;(debug:print 4 "qry: " qry) 
		   qry)
		 qryvals)
	  (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
	  res) 
	(begin
	  (debug:print 0 "ERROR: Called without all necessary keys")
	  #f))))


;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs db runpatt count offset keypatts)
  (let* ((res       '())
	 (keys       (db:get-keys db))
	 (runpattstr (db:patt->like "runname" runpatt))
	 (remfields  (list "id" "runname" "state" "status" "owner" "event_time"))
	 (header     (append keys remfields))

	 (keystr     (conc (keys->keystr keys) ","
		           (string-intersperse remfields ",")))
	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
		           ;; Generate: " AND x LIKE 'keypatt' ..."
		           (if (null? keypatts) ""
		               (conc " AND "
				     (string-join 
				      (map (lambda (keypatt)
					     (let ((key  (car keypatt))
						   (patt (cadr keypatt)))
					       (db:patt->like key patt)))
					   keypatts)
				      " AND ")))
		           " AND state != 'deleted' ORDER BY event_time DESC "
		           (if (number? count)
		               (conc " LIMIT " count)
		               "")
		           (if (number? offset)
		               (conc " OFFSET " offset)
		               ""))))
    (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
    (sqlite3:for-each-row
     (lambda (a . x)
       (set! res (cons (apply vector a x) res)))
     db
     qrystr
     )
    (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
    (vector header res)))

;; Get all targets from the db
;;
(define (db:get-targets db)
  (let* ((res       '())
	 (keys       (db:get-keys db))
	 (header     keys) ;; (map key:get-fieldname keys))
	 (keystr     (keys->keystr keys))
	 (qrystr     (conc "SELECT " keystr " FROM runs;"))
	 (seen       (make-hash-table)))
    (sqlite3:for-each-row
     (lambda (a . x)
       (let ((targ (cons a x)))
	 (if (not (hash-table-ref/default seen targ #f))
	     (begin
	       (hash-table-set! seen targ #t)
	       (set! res (cons (apply vector targ) res))))))
     db
     qrystr)
    (debug:print-info 11 "db:get-targets END qrystr: " qrystr )
    (vector header res)))

;; just get count of runs
(define (db:get-num-runs db runpatt)
  (let ((numruns 0))
    (debug:print-info 11 "db:get-num-runs START " runpatt)
    (sqlite3:for-each-row 
     (lambda (count)
       (set! numruns count))
     db
     "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
    (debug:print-info 11 "db:get-num-runs END " runpatt)
    numruns))

;; get some basic run stats
;;
;; ( (runname (( state  count ) ... ))
;;   (   ...  
(define (db:get-run-stats db)
  (let ((totals       (make-hash-table))
	(res          '()))
    (sqlite3:for-each-row
     (lambda (runname state count)
       (let* ((stateparts (string-split state "|"))
	      (newstate   (conc (car stateparts) "\n" (cadr stateparts))))
	 (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count))
	 (set! res (cons (list runname newstate count) res))))
     db
     "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" )
    ;; (set! res (reverse res))
    (for-each (lambda (state)
		(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
	      (sort (hash-table-keys totals) string>=))
    res))

;; db:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;;  to extract info from the structure returned
;;
(define (db:get-runs-by-patt db keys runnamepatt targpatt offset limit) ;; test-name)
  (let* ((tmp      (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
	 (keystr   (car tmp))
	 (header   (cadr tmp))
	 (res     '())
	 (key-patt "")
	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
	 (qry-str  #f)
	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))
    (for-each (lambda (keyval)
		(let* ((key    (car keyval))
		       (patt   (cadr keyval))
		       (fulkey (conc ":" key))
		       (wildtype (if (substring-index "%" patt) "like" "glob")))
		  (if patt
		      (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
		      (begin
			(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
			(exit 6)))))
	      keyvals)
    (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time"
			(if limit  (conc " LIMIT " limit)   "")
			(if offset (conc " OFFSET " offset) "")
			";"))
    (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
    (sqlite3:for-each-row 
     (lambda (a . r)
       (set! res (cons (list->vector (cons a r)) res)))
     db 
     qry-str
     runnamepatt)
    (vector header res)))

;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
(define (db:get-run-info db run-id)
  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
  ;;    (hash-table-ref *run-info-cache* run-id)
  (let* ((res      #f)
	 (keys      (db:get-keys db))
	 (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
	 (header    (append keys remfields))

	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    (sqlite3:for-each-row
     (lambda (a . x)
       (set! res (apply vector a x)))
     db
     (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
     run-id)
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    (let ((finalres (vector header res)))
      ;; (hash-table-set! *run-info-cache* run-id finalres)
      finalres)))

(define (db:set-comment-for-run db run-id comment)
  (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment)
  (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)
  (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment))

;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run db run-id)
  (common:clear-caches) ;; don't trust caches after doing any deletion
  ;; First set any related tests to DELETED
  (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;"))
	(stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;")))
    (sqlite3:with-transaction
     db (lambda ()
	  (sqlite3:execute stmt1 run-id)
	  (sqlite3:execute stmt2 run-id)))
    (sqlite3:finalize! stmt1)
    (sqlite3:finalize! stmt2)))
;;  (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id))

(define (db:update-run-event_time db run-id)
  (debug:print-info 11 "db:update-run-event_time START run-id: " run-id)
  (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)
  (debug:print-info 11 "db:update-run-event_time END run-id: " run-id)) 

(define (db:lock/unlock-run db run-id lock unlock user)
  (let ((newlockval (if lock "locked"
			(if unlock
			    "unlocked"
			    "locked")))) ;; semi-failsafe
    (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
    (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
		     user (conc newlockval " " run-id))
    (debug:print-info 1 "" newlockval " run number " run-id)))

(define (db:get-run-ids db)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res (cons id res)))
     db 
     "SELECT id FROM runs;")))

;;======================================================================
;; K E Y S
;;======================================================================

;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
(define (db:get-key-val-pairs db run-id)
  (let* ((keys (db:get-keys db))
	 (res  '()))
    (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id)
    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
	 ;; (debug:print 0 "qry: " qry)
	 (sqlite3:for-each-row 
	  (lambda (key-val)
	    (set! res (cons (list key key-val) res)))
	  db qry run-id)))
     keys)
    (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id)
    (reverse res)))

;; get key vals for a given run-id
(define (db:get-key-vals db run-id)
  (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f)))
    (if mykeyvals 
	mykeyvals
	(let* ((keys (db:get-keys db))
	       (res  '()))
	  (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id)
	  (for-each 
	   (lambda (key)
	     (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
	       ;; (debug:print 0 "qry: " qry)
	       (sqlite3:for-each-row 
		(lambda (key-val)
		  (set! res (cons key-val res)))
		db qry run-id)))
	   keys)
	  (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id)

;;  T E S T S
;;======================================================================

;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by sort-order
			      #!key
			      (qryvals #f))
  (let* ((qryvalstr       (case qryvals
			    ((shortlist) "id,run_id,testname,item_path,state,status")
			    ((#f)        "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")


			    (else        qryvals)))
	 (res            '())
	 ;; if states or statuses are null then assume match all when not-in is false
	 (states-qry      (if (null? states) 
			      #f
			      (conc " state "  
				    (if not-in
					" NOT IN ('"
					" IN ('") 
				    (string-intersperse states   "','")
				    "')")))
	 (statuses-qry    (if (null? statuses)
			      #f
			      (conc " status "
				    (if not-in 
					" NOT IN ('"
					" IN ('") 
				    (string-intersperse statuses "','")
				    "')")))
	 (states-statuses-qry 
	  (cond 
	   ((and states-qry statuses-qry)
	    (conc " AND ( " states-qry " AND " statuses-qry " ) "))
	   (states-qry  
	    (conc " AND " states-qry))
	   (statuses-qry 
	    (conc " AND " statuses-qry))
	   (else "")))
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT " qryvalstr
				" FROM tests WHERE run_id=? AND state != 'DELETED' "

				states-statuses-qry
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
				(case sort-by
				  ((rundir)      " ORDER BY length(rundir) ")
				  ((testname)    (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
				  ((statestatus) (conc " ORDER BY state " (if  sort-order (conc sort-order ",") "") " status "))
				  ((event_time)  " ORDER BY event_time ")
				  (else          (if (string? sort-by)
						     (conc " ORDER BY " sort-by)
						     "")))
				(if sort-order sort-order "")
				(if limit  (conc " LIMIT " limit)   "")
				(if offset (conc " OFFSET " offset) "")
				";"
				)))
    (debug:print-info 8 "db:get-tests-for-run qry=" qry)
    (sqlite3:for-each-row 
     (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
     db 
     qry
     run-id
     )
    (case qryvals
      ((shortlist)(map db:test-short-record->norm res))
      ((#f)       res)
      (else       res))))

(define (db:test-short-record->norm inrec)
  ;;  "id,run_id,testname,item_path,state,status"
  ;;  "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
  (vector (vector-ref inrec 0) ;; id
	  (vector-ref inrec 1) ;; run_id
	  (vector-ref inrec 2) ;; testname
	  (vector-ref inrec 4) ;; state
	  (vector-ref inrec 5) ;; status
	  -1 "" -1 -1 "" "-" 
	  (vector-ref inrec 3) ;; item-path
	  -1 "-" "-"))


(define (db:get-tests-for-run-state-status db run-id testpatt)
  (let ((res            '())
	(tests-match-qry (tests:match->sqlqry testpatt)))
    (sqlite3:for-each-row
     (lambda (id testname item-path state status)
       ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
       (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
     db 
     (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " 
	   (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))
     run-id)
    res))

(define (db:get-testinfo-state-status db test-id)
  (let ((res            #f))
    (sqlite3:for-each-row
     (lambda (run-id testname item-path state status)
       ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
       (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
     db 
     "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" 
     test-id)
    res))

;; get a useful subset of the tests data (used in dashboard
;; use db:mintests-get-{id ,run_id,testname ...}
(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in)
  (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))


;; NB // This is get tests for "runs" (note the plural!!)
;;
;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
;; run-ids is a list of run-ids or a single number or #f for all runs
(define (db:get-tests-for-runs db run-ids testpatt states statuses 
			       #!key (not-in #t)
			       (sort-by #f)
			       (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time

  (let* ((res '())
	 ;; if states or statuses are null then assume match all when not-in is false
	 (states-qry      (if (null? states) 
			      #f
			      (conc " state "  
				    (if not-in "NOT" "") 
				    " IN ('" 
				    (string-intersperse states   "','")
				    "')")))
	 (statuses-qry    (if (null? statuses)
			      #f
			      (conc " status "
				    (if not-in "NOT" "") 
				    " IN ('" 
				    (string-intersperse statuses "','")
				    "')")))
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT " qryvals 
				" FROM tests WHERE state != 'DELETED' "
				(if run-ids
				    (if (list? run-ids)
					(conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ")
					(conc "AND run_id=" run-ids " "))
				    " ") ;; #f => run-ids don't filter on run-ids
				(if states-qry   (conc " AND " states-qry)   "")
				(if statuses-qry (conc " AND " statuses-qry) "")
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
				(case sort-by
				  ((rundir)     " ORDER BY length(rundir) DESC;")
				  ((event_time) " ORDER BY event_time ASC;")
				  (else         ";"))
				)))
    (debug:print-info 8 "db:get-tests-for-runs qry=" qry)
    (sqlite3:for-each-row 
     (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
     db 
     qry
     )

    res))

;; this one is a bit broken BUG FIXME
(define (db:delete-test-step-records db test-id #!key (work-area #f))
  ;; Breaking it into two queries for better file access interleaving
  (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
    ;; test db's can go away - must check every time
    (if (sqlite3:database? tdb)
	(begin
	  (sqlite3:execute tdb "DELETE FROM test_steps;")
	  (sqlite3:execute tdb "DELETE FROM test_data;")
	  (sqlite3:finalize! tdb)))))

;; 
(define (db:delete-test-records db tdb test-id #!key (force #f))
  (common:clear-caches)
  (if tdb 
      (begin
	(sqlite3:execute tdb "DELETE FROM test_steps;")
	(sqlite3:execute tdb "DELETE FROM test_data;")))
  ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id))
  (if db 
      (begin
	(sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id)
	(sqlite3:execute db "DELETE FROM test_data  WHERE test_id=?;" test-id)
	(if force
	    (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)
	    (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))))

(define (db:delete-tests-for-run db run-id)
  (common:clear-caches)
  (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id))

(define (db:delete-old-deleted-test-records db)
  (common:clear-caches)

(define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree)
  (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id))

(define (cdb:tests-update-run-duration serverdat test-id minutes)
  (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id))

(define (cdb:tests-update-uname-host serverdat test-id uname hostname)
  (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id))

;; speed up for common cases with a little logic
;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
  (cond
   ((and newstate newstatus newcomment)
    (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id))
   ((and newstate newstatus)
    (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
   (else
    (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
    (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
    (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))
  (mt:process-triggers test-id newstate newstatus))

;; Never used, but should be?
(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
  (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" 
 		   state status run-id test-name item-path))

(define (db:get-count-tests-running db)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted');")
    res))

(define (db:get-count-tests-running-for-run-id db run-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" run-id)
    res))

(define (db:get-running-stats db)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (state count)
       (set! res (cons (list state count) res)))
     db
     "SELECT state,count(id) FROM tests GROUP BY state ORDER BY id DESC;")
    res))

(define (db:get-count-tests-running-in-jobgroup db jobgroup)
  (if (not jobgroup)
      0 ;; 
      (let ((res 0))
	(sqlite3:for-each-row
	 (lambda (count)
	   (set! res count))
	 db
	 "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART')
             AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?);"
	 jobgroup)
	res)))

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining db run-id)
  (let ((res 0))

	res)))

(define (db:get-test-info db run-id testname item-path)
  (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path)))

(define (db:test-set-comment db test-id comment)
  (sqlite3:execute 
   db
   "UPDATE tests SET comment=? WHERE id=?;"
   comment test-id))

(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir)
  (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path))

(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir)

;; MUST BE CALLED local!
(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '()))
  ;; BUG: Move the values derived from args to parameters and push to megatest.scm
  (let* ((testpatt   (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
	 (statepatt  (if (args:get-arg ":state")   (args:get-arg ":state")    "%"))
	 (statuspatt (if (args:get-arg ":status")  (args:get-arg ":status")   "%"))
	 (runname    (if (args:get-arg ":runname") (args:get-arg ":runname")  "%"))
	 (paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target-new db keynames target res
					testpatt:   testpatt
					statepatt:  statepatt
					statuspatt: statuspatt
					runname:    runname)))
    (if fnamepatt
	(apply append 
	       (map (lambda (p)

		       (string-split target "/"))
		  " AND "))
	 (testqry (tests:match->sqlqry testpatt))
	 (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
		       keystr " AND r.runname LIKE '" runname "' AND " testqry
		       " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt 
		       "' ORDER BY t.event_time ASC;")))

    (sqlite3:for-each-row 
     (lambda (p)
       (set! res (cons p res)))
     db 
     qrystr)
    res))

(define (db:test-get-paths-matching-keynames-target-new db keynames target res 
							#!key
							(testpatt   "%")
							(statepatt  "%")
							(statuspatt "%")
							(runname    "%"))
  (let* ((row-ids '())
	 (keystr (string-intersperse 
		  (map (lambda (key val)
			 (conc key " like '" val "'"))
		       keynames 
		       (string-split target "/"))
		  " AND "))
	 (testqry (tests:match->sqlqry testpatt))
	 (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))
	 (tstsqry (sqlite3:prepare db (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))))
    (sqlite3:for-each-row
     (lambda (rid)
       (set! row-ids (cons rid row-ids)))
     runsqry)
    (for-each (lambda (rid)
		(sqlite3:for-each-row 
		 (lambda (p)
		   (set! res (cons p res)))
		 tstsqry rid))
	      row-ids)
    (sqlite3:finalize! tstsqry)
    (sqlite3:finalize! runsqry)
    res))

;; look through tests from matching runs for a file
(define (db:test-get-first-path-matching db keynames target fname)
  ;; [refpaths] is the section where references to other megatest databases are stored
  (let ((mt-paths (configf:get-section "refpaths"))
	(res       (db:test-get-paths-matching db keynames target fname)))
    (let loop ((pathdat (if (null? paths) #f (car mt-paths)))

      (base64:base64-encode (with-output-to-string (lambda ()(serialize obj))))
      #t))
    ((zmq)(with-output-to-string (lambda ()(serialize obj))))
    (else obj)))

(define (db:string->obj msg)
  (case *transport-type*
    ((fs) msg)
    ((http)
     (if (string? msg)
	 (with-input-from-string 
	     (base64:base64-decode
	      (string-substitute 
	       (regexp "_") "=" msg #t))
	   (lambda ()(deserialize)))
	 (vector #f #f #f))) ;; crude reply for when things go awry
    ((zmq)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg)))

(define (cdb:use-non-blocking-mode proc)
  (set! *client-non-blocking-mode* #t)
  (let ((res (proc)))
    (set! *client-non-blocking-mode* #f)
    res))

;; params = 'target cached remparams
;;
;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime
;;
;; cdb:client-call is the unified interface to all the transports. It dispatches the
;;                 query to a server routine (e.g. server:client-send-recieve) that 
;;                 transports the data to the server where it is passed to db:process-queue-item

			       ;; we will need to process "all" messages here some day
			       (receive-message* sub-socket)
			       ;; now get the actual message
			       (let ((myres (db:string->obj (receive-message* sub-socket))))
				 (if (equal? query-sig (vector-ref myres 1))
				     (set! res (vector-ref myres 2))
				     (loop)))))))
	;; (timeout (lambda ()
	;;     	(let loop ((n numretries))
	;;     	  (thread-sleep! 15)
	;;     	  (if (not res)
	;;     	      (if (> numretries 0)
	;;     		  (begin
	;;     		    (debug:print 2 "WARNING: no reply to query " params ", trying resend")
	;;     		    (debug:print-info 11 "re-sending message")
	;;     		    (send-message push-socket zdat)
	;;     		    (debug:print-info 11 "message re-sent")
	;;     		    (loop (- n 1)))
	;;     		  ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params))
	;;     		  (begin
	;;     		    (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.")
	;;     		    (exit 5))))))))
	(debug:print-info 11 "Starting threads")
	(let ((th1 (make-thread send-receive "send receive"))
	      ;; (th2 (make-thread timeout      "timeout"))
	      )
	  (thread-start! th1)
	  ;; (thread-start! th2)
	  (thread-join!  th1)
	  (debug:print-info 11 "cdb:client-call returning res=" res)
	  res))))))

(define (cdb:set-verbosity serverdat val)
  (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))

(define (cdb:login serverdat keyval signature)
  (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))

(define (cdb:logout serverdat keyval signature)
  (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature))

(define (cdb:num-clients serverdat)
  (cdb:client-call serverdat 'numclients #t *default-numtries*))

;; I think this would be more efficient if executed on client side FIXME???
(define (cdb:test-set-status-state serverdat test-id status state msg)
  (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
      (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id))
  (if msg
      (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id)
      (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) 

(define (cdb:test-rollup-test_data-pass-fail serverdat test-id)
  (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id))

(define (cdb:pass-fail-counts serverdat test-id fail-count pass-count)
  (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id))

(define (cdb:tests-register-test serverdat run-id test-name item-path)
  (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path))

;; more transactioned calls, these for roll-up-pass-fail stuff
(define (cdb:update-pass-fail-counts serverdat run-id test-name)
  (cdb:client-call serverdat 'update-fail-pass-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name))

(define (cdb:top-test-set-running serverdat run-id test-name)
  (cdb:client-call serverdat 'top-test-set-running #t *default-numtries* run-id test-name))

(define (cdb:top-test-set-per-pf-counts serverdat run-id test-name)
  (cdb:client-call serverdat 'top-test-set-per-pf-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name))

;;=

(define (cdb:flush-queue serverdat)
  (cdb:client-call serverdat 'flush #f *default-numtries*))

(define (cdb:kill-server serverdat pid)
  (cdb:client-call serverdat 'killserver #t *default-numtries* pid))

(define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status)
  (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status))

(define (cdb:get-test-info serverdat run-id test-name item-path)
  (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path))

(define (cdb:get-test-info-by-id serverdat test-id)
  (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)))
    (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed
    test-dat))

;; db should be db open proc or #f
(define (cdb:remote-run proc db . params)
  (if (or *db-write-access*
	  (not (member proc *db:all-write-procs*)))
      (handle-exceptions
       exn
       (begin 
	 (debug:print 0 "Problem with call to cdb:remote-run, database may be locked and read-only, waiting and trying again ...")
	 (thread-sleep! 10)
	 (apply cdb:remote-run proc db params))
       (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params))
      (begin
	(debug:print 0 "ERROR: Attempt to access read-only database")
	#f)))

(define (db:test-get-logfile-info db run-id test-name)
  (let ((res #f))
    (sqlite3:for-each-row 
     (lambda (path final_logf)
       (set! logf final_logf)
       (set! res (list path final_logf))

;;======================================================================
;; A G R E G A T E D   T R A N S A C T I O N   D B   W R I T E S 
;;======================================================================

(define db:queries 
  (list '(register-test          "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
	;; Test state and status
	'(set-test-state         "UPDATE tests SET state=?   WHERE id=?;")
	'(set-test-status        "UPDATE tests SET state=?   WHERE id=?;")
	'(state-status           "UPDATE tests SET state=?,status=? WHERE id=?;")
	'(state-status-msg       "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;")
	;; Test comment
	'(set-test-comment       "UPDATE tests SET comment=? WHERE id=?;")
	'(set-test-start-time    "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;")
	'(pass-fail-counts       "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;")
	;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
	'(test_data-pf-rollup    "UPDATE tests
                                    SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
                                      THEN 'FAIL'
                                    WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
                                      (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
                                    THEN 'PASS'
                                    ELSE status
                                    END WHERE id=?;")
	'(test-set-log            "UPDATE tests SET final_logf=? WHERE id=?;")
	'(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?")
	'(test-set-rundir         "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;")
	'(delete-tests-in-state   "DELETE FROM tests WHERE state=? AND run_id=?;")
	'(tests:test-set-toplog   "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
	'(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;")
	'(update-run-duration     "UPDATE tests SET run_duration=? WHERE id=?;")
	'(update-uname-host       "UPDATE tests SET uname=?,host=? WHERE id=?;")
	'(update-test-state       "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
	'(update-test-status      "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
	;; stuff for roll-up-pass-fail-counts
	'(update-fail-pass-counts "UPDATE tests 
             SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')),
                 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
             WHERE run_id=? AND testname=? AND item_path='';")
	'(top-test-set-running  "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';")
	'(top-test-set-per-pf-counts "UPDATE tests
                       SET state=CASE 
                                   WHEN (SELECT count(id) FROM tests 
                                                WHERE run_id=? AND testname=?
                                                     AND item_path != '' 
                                                     AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
                                   ELSE 'COMPLETED' END,
                            status=CASE 
                                  WHEN fail_count > 0 THEN 'FAIL' 
                                  WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' 
                                  WHEN (SELECT count(id) FROM tests
                                         WHERE run_id=? AND testname=?
                                              AND item_path != ''
                                              AND status = 'SKIP') > 0 THEN 'SKIP'
                                  ELSE 'UNKNOWN' END
                       WHERE run_id=? AND testname=? AND item_path='';")
	))

;; do not run these as part of the transaction
(define db:special-queries   '(rollup-tests-pass-fail
			       ;; db:roll-up-pass-fail-counts  ;; WHY NOT!?
			       login
			       immediate
			       flush
			       sync
			       set-verbosity
			       killserver
			       ))

;; not used, intended to indicate to run in calling process

    (set! *server:last-write-flush* (current-milliseconds))
    (set! *incoming-writes* '())
    (mutex-unlock! *incoming-mutex*)
    (if (> (length data) 0)
	;; Process if we have data
	(begin
	  (debug:print-info 7 "Writing cached data " data)
	  
	  ;; Prepare the needed sql statements
	  ;;
	  (for-each (lambda (request-item)
		      (let ((stmt-key (vector-ref request-item 0))
			    (query    (vector-ref request-item 1)))
			(hash-table-set! queries stmt-key (sqlite3:prepare db query))))
		    data)

	       (< (current-seconds) timeout))
	  (begin
	    (thread-sleep! 0.01)
	    (loop))))
    (set! *number-of-writes*   (+ *number-of-writes*   1))
    (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time)))
    got-it))

(define (db:process-queue-item db item)
  (let* ((stmt-key       (cdb:packet-get-qtype item))
	 (qry-sig        (cdb:packet-get-query-sig item))
	 (return-address (cdb:packet-get-client-sig item))
	 (params         (cdb:packet-get-params item))
	 (query          (let ((q (alist-ref stmt-key db:queries)))
			   (if q (car q) #f))))
    (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params)
    (if query
	;; hand queries off to the write queue
	(let ((response (case *transport-type*
			  ((http)
			   (debug:print-info 7 "Queuing item " item " for wrapped write")
			   (db:queue-write-and-wait db qry-sig query params))
			  (else 
			   (apply sqlite3:execute db query params)
			   #t))))
	  (debug:print-info 7 "Received " response " from wrapped write")
	  (server:reply return-address qry-sig response response))
	;; otherwise if appropriate flush the queue (this is a read or complex query)
	(begin
	  (cond

			     (hash-table-set! *logged-in-clients* client-key (current-seconds))
			     (server:reply return-address qry-sig #t '(#t "successful login")))      ;; path matches - pass! Should vet the caller at this time ...
			   (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
		((flush sync)
		 (server:reply return-address qry-sig #t 1)) ;; (length data)))
		((set-verbosity)
		 (set! *verbosity* (car params))
		 (server:reply return-address qry-sig #t (list #t *verbosity*)))
		((killserver)
		 (let ((hostname (car  *runremote*))
		       (port     (cadr *runremote*))
		       (pid      (car params)))
		   (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
		   (debug:print-info 1 "current pid=" (current-process-id))
		   (open-run-close tasks:server-deregister tasks:open-db 

				   hostname
				   port: port)
		   (set! *server-run* #f)
		   (thread-sleep! 3)
		   (process-signal pid signal/kill)
		   (server:reply return-address qry-sig #t '(#t "exit process started"))))
		(else ;; not a command, i.e. is a query
		 (debug:print 0 "ERROR: Unrecognised query/command " stmt-key)
		 (server:reply return-address qry-sig #f 'failed)))))
	   (else
	    (debug:print-info 11 "Executing " stmt-key " for " params)
	    (apply sqlite3:execute (hash-table-ref queries stmt-key) params)
	    (server:reply return-address qry-sig #t #t)))))))

(define (db:test-get-records-for-index-file db run-id test-name)
  (let ((res '()))
    (sqlite3:for-each-row 
     (lambda (id itempath state status run_duration logf comment)
       (set! res (cons (vector id itempath state status run_duration logf comment) res)))
     db
     "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';"
     run-id test-name)
    res))








































;;======================================================================
;; Tests meta data
;;======================================================================

;; read the record given a testname
(define (db:testmeta-get-record db testname)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
       (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
     db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
     testname)
    res))

;; create a new record for a given testname
(define (db:testmeta-add-record db testname)
  (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))

;; update one of the testmeta fields
(define (db:testmeta-update-field db testname field value)
  (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))

;;======================================================================
;; T E S T   D A T A 
;;======================================================================

(define (db:csv->test-data db test-id csvdata #!key (work-area #f))
  (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
  (let ((tdb     (db:open-test-db-by-test-id db test-id work-area: work-area)))
    (if (sqlite3:database? tdb)
	(let ((csvlist (csv->list (make-csv-reader
				   (open-input-string csvdata)
				   '((strip-leading-whitespace? #t)
				     (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata)))
	  (for-each 
	   (lambda (csvrow)
	     (let* ((padded-row  (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))

				test-id category variable value expected tol units (if comment comment "") status type)))
	   csvlist)
	  (sqlite3:finalize! tdb)))))

;; get a list of test_data records matching categorypatt
(define (db:read-test-data db test-id categorypatt #!key (work-area #f))
  (let ((tdb  (db:open-test-db-by-test-id db test-id work-area: work-area)))
    (if (sqlite3:database? tdb)
	(let ((res '()))
	  (sqlite3:for-each-row 
	   (lambda (id test_id category variable value expected tol units comment status type)
	     (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
	   tdb
	   "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
	  (sqlite3:finalize! tdb)

;; look at the test_data status field, 
;;    if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;;    if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup db test-id status #!key (work-area #f))
  (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
	(fail-count 0)
	(pass-count 0))
    (if (sqlite3:database? tdb)
	(begin
	  (sqlite3:for-each-row
	   (lambda (fcount pcount)
	     (set! fail-count fcount)
	     (set! pass-count pcount))
	   tdb 
	   "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,

	  ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set
	  
	  ;; if the test is not FAIL then set status based on the fail and pass counts.
	  (cdb:test-rollup-test_data-pass-fail *runremote* test-id)
	  ;; (sqlite3:execute
	  ;;  db   ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME
	  ;;  "UPDATE tests
	  ;;             SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
	  ;;                THEN 'FAIL'
	  ;;             WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
	  ;;                  (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
	  ;;             THEN 'PASS'
	  ;;             ELSE status
	  ;;         END WHERE id=?;"
	  ;;  test-id test-id test-id test-id)
	  ))))

(define (db:get-prev-tol-for-test db test-id category variable)
  ;; Finish me?
  (values #f #f #f))

;;======================================================================
;; S T E P S 
;;======================================================================

(define (db:step-get-time-as-string vec)
  (seconds->time-string (db:step-get-event_time vec)))

;; db-get-test-steps-for-run
(define (db:get-steps-for-test db test-id #!key (work-area #f))
  (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
	 (res '()))
    (if (sqlite3:database? tdb)
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 0 "ERROR: error on access to testdat for test with id " test-id)
	   '())
	 (begin
	   (sqlite3:for-each-row 
	    (lambda (id test-id stepname state status event-time logfile)
	      (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
	    tdb
	    "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
	    test-id)
	   (sqlite3:finalize! tdb)
	   (reverse res)))
	'())))

;; get a pretty table to summarize steps
;;
(define (db:get-steps-table db test-id #!key (work-area #f))
  (let ((steps   (db:get-steps-for-test db test-id work-area: work-area)))
    ;; organise the steps for better readability

		     (cond
		      ((<   (db:step-get-event_time a)(db:step-get-event_time b)) #t)
		      ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) 
		       (<   (db:step-get-id a)        (db:step-get-id b)))
		      (else #f)))))
      res)))

(define (db:get-compressed-steps test-id #!key (work-area #f)(tdb #f))
  (if (or (not work-area)
	  (file-exists? (conc work-area "/testdat.db")))
      (let* ((comprsteps (open-run-close db:get-steps-table tdb test-id work-area: work-area)))
	(map (lambda (x)
	       ;; take advantage of the \n on time->string
	       (vector
		(vector-ref x 0)
		(let ((s (vector-ref x 1)))
		  (if (number? s)(seconds->time-string s) s))
		(let ((s (vector-ref x 2)))

;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met:
;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;;       mode 'toplevel means that tests must be COMPLETED only
;;       mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;; 
(define (db:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
  (if (or (not waitons)
	  (null? waitons))
      '()
      (let* ((unmet-pre-reqs '())
	     (result         '()))
	(for-each 
	 (lambda (waitontest-name)
	   ;; by getting the tests with matching name we are looking only at the matching test 
	   ;; and related sub items
	   (let ((tests             (cdb:remote-run db:get-tests-for-run-state-status #f run-id waitontest-name)) ;; (mt:get-tests-for-run run-id waitontest-name '() '()))
		 (ever-seen         #f)
		 (parent-waiton-met #f)
		 (item-waiton-met   #f))
	     (for-each 
	      (lambda (test)
		;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
		(let* ((state             (db:test-get-state test))
		       (status            (db:test-get-status test))
		       (item-path         (db:test-get-item-path test))
		       (is-completed      (equal? state "COMPLETED"))
		       (is-running        (equal? state "RUNNING"))
		       (is-killed         (equal? state "KILLED"))
		       (is-ok             (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))
		       (same-itempath     (equal? ref-item-path item-path)))
		  (set! ever-seen #t)
		  (cond
		   ;; case 1, non-item (parent test) is 
		   ((and (equal? item-path "") ;; this is the parent test
			 is-completed
			 (or is-ok (member mode '(toplevel itemmatch itemwait))))
		    (set! parent-waiton-met #t))
		   ;; Special case for toplevel and KILLED
		   ((and (equal? item-path "") ;; this is the parent test
			 is-killed
			 (eq? mode 'toplevel))
		    (set! parent-waiton-met #t))
		   ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
		   ((and (member mode '(itemmatch itemwait))
			 ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items
			 same-itempath)
		    (if (and is-completed is-ok)
			(set! item-waiton-met #t))
		    (if (and (equal? item-path "")
			     (or is-completed is-running));; this is the parent, set it to run if completed or running
			(set! parent-waiton-met #t)))
		   ;; normal checking of parent items, any parent or parent item not ok blocks running
		   ((and is-completed
			 (or is-ok 
			     (eq? mode 'toplevel))              ;; toplevel does not block on FAIL
			 (and is-ok (eq? mode 'itemmatch))) ;; itemmatch blocks on not ok
		    (set! item-waiton-met #t)))))
	      tests)
	     ;; both requirements, parent and item-waiton must be met to NOT add item to
	     ;; prereq's not met list
	     (if (not (or parent-waiton-met item-waiton-met))
		 (set! result (append (if (null? tests) (list waitontest-name) tests) result)))
	     ;; if the test is not found then clearly the waiton is not met...
	     ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
	     (if (not ever-seen)
		 (set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
	 waitons)
	(delete-duplicates result))))

(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f))

  ;;                 db:open-test-db-by-test-id does cdb:remote-run
  (let* ((tdb       (db:open-test-db-by-test-id db test-id work-area: work-area))
	 (state     (items:check-valid-items "state" state-in))
	 (status    (items:check-valid-items "status" status-in)))
    (if (or (not state)(not status))
	(debug:print 3 "WARNING: Invalid " (if status "status" "state")
		     " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
    (if (sqlite3:database? tdb)
	(begin
	  (sqlite3:execute 
	   tdb
	   "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
	   test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))
	  (sqlite3:finalize! tdb)
	  #t)

	   (debug:print 0 "WARNING: path given, " outputfile " is relative, prefixing with current directory")
	   (conc (current-directory) "/" outputfile)))
     results)
    ;; brutal clean up
    (system "rm -rf tempdir")))

;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")

;; This is a list of all procs that write to the db
;;
(define *db:all-write-procs*
  (list 
   db:set-var 
   db:del-var
   db:register-run
   db:set-comment-for-run
   db:delete-run
   db:update-run-event_time
   db:lock/unlock-run 
   db:delete-test-step-records
   db:delete-test-records
   db:delete-tests-for-run
   db:delete-old-deleted-test-records
   db:set-tests-state-status
   db:test-set-state-status-by-id
   db:test-set-state-status-by-run-id-testname
   db:test-set-comment
   db:testmeta-add-record
   db:csv->test-data
   db:test-data-rollup
   db:teststep-set-status! ))

(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id           vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id       vec) (vector-ref vec 1))
(define-inline (db:test-get-testname     vec) (vector-ref vec 2))
(define-inline (db:test-get-state        vec) (vector-ref vec 3))
(define-inline (db:test-get-status       vec) (vector-ref vec 4))
(define-inline (db:test-get-event_time   vec) (vector-ref vec 5))
(define-inline (db:test-get-host         vec) (vector-ref vec 6))

;;======================================================================
;; Copyright 2006-2013, 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 regex)

(declare (unit dcommon))

(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses synchash))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")

;; yes, this is non-ideal 
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)

;;======================================================================
;; C O M M O N   D A T A   S T R U C T U R E
;;======================================================================
;; 
;; A single data structure for all the data used in a dashboard.
;; Share this structure between newdashboard and dashboard with the 
;; intent of converging on a single app.
;;
(define *data* (make-vector 25 #f))
(define (dboard:data-get-runs          vec)    (vector-ref  vec 0))
(define (dboard:data-get-tests         vec)    (vector-ref  vec 1))
(define (dboard:data-get-runs-matrix   vec)    (vector-ref  vec 2))
(define (dboard:data-get-tests-tree    vec)    (vector-ref  vec 3))
(define (dboard:data-get-run-keys      vec)    (vector-ref  vec 4))
(define (dboard:data-get-curr-test-ids vec)    (vector-ref  vec 5))
;; (define (dboard:data-get-test-details  vec)    (vector-ref  vec 6))
(define (dboard:data-get-path-test-ids vec)    (vector-ref  vec 7))
(define (dboard:data-get-updaters      vec)    (vector-ref  vec 8))
(define (dboard:data-get-path-run-ids  vec)    (vector-ref  vec 9))
(define (dboard:data-get-curr-run-id   vec)    (vector-ref  vec 10))
(define (dboard:data-get-runs-tree     vec)    (vector-ref  vec 11))
;; For test-patts convert #f to ""
(define (dboard:data-get-test-patts    vec)    
  (let ((val (vector-ref  vec 12)))(if val val "")))
(define (dboard:data-get-states        vec)    (vector-ref vec 13))
(define (dboard:data-get-statuses      vec)    (vector-ref vec 14))
(define (dboard:data-get-logs-textbox  vec val)(vector-ref vec 15))
(define (dboard:data-get-command       vec)    (vector-ref vec 16))
(define (dboard:data-get-command-tb    vec)    (vector-ref vec 17))
(define (dboard:data-get-target        vec)    (vector-ref vec 18))
(define (dboard:data-get-target-string vec)
  (let ((targ (dboard:data-get-target vec)))
    (if (list? targ)(string-intersperse targ "/") "no-target-specified")))
(define (dboard:data-get-run-name      vec)    (vector-ref vec 19))
(define (dboard:data-get-runs-listbox  vec)    (vector-ref vec 20))

(define (dboard:data-set-runs!          vec val)(vector-set! vec 0 val))
(define (dboard:data-set-tests!         vec val)(vector-set! vec 1 val))
(define (dboard:data-set-runs-matrix!   vec val)(vector-set! vec 2 val))
(define (dboard:data-set-tests-tree!    vec val)(vector-set! vec 3 val))
(define (dboard:data-set-run-keys!      vec val)(vector-set! vec 4 val))
(define (dboard:data-set-curr-test-ids! vec val)(vector-set! vec 5 val))
;; (define (dboard:data-set-test-details!  vec val)(vector-set! vec 6 val))
(define (dboard:data-set-path-test-ids! vec val)(vector-set! vec 7 val))
(define (dboard:data-set-updaters!      vec val)(vector-set! vec 8 val))
(define (dboard:data-set-path-run-ids!  vec val)(vector-set! vec 9 val))
(define (dboard:data-set-curr-run-id!   vec val)(vector-set! vec 10 val))
(define (dboard:data-set-runs-tree!     vec val)(vector-set! vec 11 val))
;; For test-patts convert "" to #f 
(define (dboard:data-set-test-patts!    vec val)
  (vector-set! vec 12 (if (equal? val "") #f val)))
(define (dboard:data-set-states!        vec val)(vector-set! vec 13 val))
(define (dboard:data-set-statuses!      vec val)(vector-set! vec 14 val))
(define (dboard:data-set-logs-textbox!  vec val)(vector-set! vec 15 val))
(define (dboard:data-set-command!       vec val)(vector-set! vec 16 val))
(define (dboard:data-set-command-tb!    vec val)(vector-set! vec 17 val))
(define (dboard:data-set-target!        vec val)(vector-set! vec 18 val))
(define (dboard:data-set-run-name!      vec val)(vector-set! vec 19 val))
(define (dboard:data-set-runs-listbox!  vec val)(vector-set! vec 20 val))

(dboard:data-set-run-keys! *data* (make-hash-table))

;; List of test ids being viewed in various panels
(dboard:data-set-curr-test-ids! *data* (make-hash-table))

;; Look up test-ids by (key1 key2 ... testname [itempath])
(dboard:data-set-path-test-ids! *data* (make-hash-table))

;; Look up run-ids by ??
(dboard:data-set-path-run-ids! *data* (make-hash-table))

;;======================================================================
;; TARGET AND PATTERN MANIPULATIONS
;;======================================================================

;; Convert to and from list of lines (for a text box)
;; "," => "\n"
(define (dboard:test-patt->lines test-patt)
  (string-substitute (regexp ",") "\n" test-patt))

(define (dboard:lines->test-patt lines)
  (string-substitute (regexp "\n") "," lines #t))


;;======================================================================
;; P R O C E S S   R U N S
;;======================================================================

;; MOVE THIS INTO *data*
(define *cachedata* (make-hash-table))
(hash-table-set! *cachedata* "runid-to-col"    (make-hash-table))
(hash-table-set! *cachedata* "testname-to-row" (make-hash-table))

;; 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
;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
(define (run-update keys data runname keypatts testpatt states statuses mode window-id)
  (let* (;; count and offset => #f so not used
	 ;; the synchash calls modify the "data" hash
	 (get-runs-sig    (conc (client:get-signature) " get-runs"))
	 (get-tests-sig   (conc (client:get-signature) " get-tests"))
	 (get-details-sig (conc (client:get-signature) " get-test-details"))

	 ;; test-ids to get and display are indexed on window-id in curr-test-ids hash
	 (test-ids        (hash-table-values (dboard:data-get-curr-test-ids *data*)))

 	 (run-changes     (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts))
	 (tests-detail-changes (if (not (null? test-ids))
				   (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0  data test-ids)
				   '()))

	 ;; Now can calculate the run-ids
	 (run-hash    (hash-table-ref/default data get-runs-sig #f))
	 (run-ids     (if run-hash (filter number? (hash-table-keys run-hash)) '()))

	 (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses #f))
	 (runs-hash    (hash-table-ref/default data get-runs-sig #f))
	 (header       (hash-table-ref/default runs-hash "header" #f))
	 (run-ids      (sort (filter number? (hash-table-keys runs-hash))
			     (lambda (a b)
			       (let* ((record-a (hash-table-ref runs-hash a))
				      (record-b (hash-table-ref runs-hash b))
				      (time-a   (db:get-value-by-header record-a header "event_time"))
				      (time-b   (db:get-value-by-header record-b header "event_time")))
				 (> time-a time-b)))
			     ))
	 (runid-to-col    (hash-table-ref *cachedata* "runid-to-col"))
	 (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) 
	 (colnum       1)
	 (rownum       0)) ;; rownum = 0 is the header
;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes)
    
	 ;; tests related stuff
	 ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes))))

    ;; Given a run-id and testname/item_path calculate a cell R:C

    ;; NOTE: Also build the test tree browser and look up table
    ;;
    ;; Each run is unique on its keys and runname or run-id, store in hash on colnum
    (for-each (lambda (run-id)
		(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
		       (key-vals   (map (lambda (key)(db:get-value-by-header run-record header key))
					keys))
		       (run-name   (db:get-value-by-header run-record header "runname"))
		       (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
		       (run-path   (append key-vals (list run-name))))
		  (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path)
		  (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
				      (conc rownum ":" colnum) col-name)
		  (hash-table-set! runid-to-col run-id (list colnum run-record))
		  ;; Here we update the tests treebox and tree keys
		  (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name))
				 userdata: (conc "run-id: " run-id))
		  (set! colnum (+ colnum 1))))
	      run-ids)

    ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
    ;; Do this analysis in the order of the run-ids, the most recent run wins
    (for-each (lambda (run-id)
		(let* ((run-path       (hash-table-ref (dboard:data-get-run-keys *data*) run-id))
		       (new-test-dat   (car test-changes))
		       (removed-tests  (cadr test-changes))
		       (tests          (sort (map cadr (filter (lambda (testrec)
								 (eq? run-id (db:mintest-get-run_id (cadr testrec))))
							       new-test-dat))
					     (lambda (a b)
					       (let ((time-a (db:mintest-get-event_time a))
						     (time-b (db:mintest-get-event_time b)))
						 (> time-a time-b)))))
		       ;; test-changes is a list of (( id record ) ... )
		       ;; Get list of test names sorted by time, remove tests
		       (test-names (delete-duplicates (map (lambda (t)
							     (let ((i (db:mintest-get-item_path t))
								   (n (db:mintest-get-testname  t)))
							       (if (string=? i "")
								   (conc "   " i)
								   n)))
							   tests)))
		       (colnum     (car (hash-table-ref runid-to-col run-id))))
		  ;; for each test name get the slot if it exists and fill in the cell
		  ;; or take the next slot and fill in the cell, deal with items in the
		  ;; run view panel? The run view panel can have a tree selector for
		  ;; browsing the tests/items

		  ;; SWITCH THIS TO USING CHANGED TESTS ONLY
		  (for-each (lambda (test)
			      (let* ((test-id   (db:mintest-get-id test))
				     (state     (db:mintest-get-state test))
				     (status    (db:mintest-get-status test))
				     (testname  (db:mintest-get-testname test))
				     (itempath  (db:mintest-get-item_path test))
				     (fullname  (conc testname "/" itempath))
				     (dispname  (if (string=? itempath "") testname (conc "   " itempath)))
				     (rownum    (hash-table-ref/default testname-to-row fullname #f))
				     (test-path (append run-path (if (equal? itempath "") 
								     (list testname)
								     (list testname itempath)))))
				(tree:add-node (dboard:data-get-tests-tree *data*) "Runs" 
					       test-path
					       userdata: (conc "test-id: " test-id))
				(hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id)
				(if (not rownum)
				    (let ((rownums (hash-table-values testname-to-row)))
				      (set! rownum (if (null? rownums)
						       1
						       (+ 1 (apply max rownums))))
				      (hash-table-set! testname-to-row fullname rownum)
				      ;; create the label
				      (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
							  (conc rownum ":" 0) dispname)
				      ))
				;; set the cell text and color
				;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status)
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc rownum ":" colnum)
						    (if (string=? state "COMPLETED")
							status
							state))
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc "BGCOLOR" rownum ":" colnum)
						    (car (gutils:get-color-for-state-status state status)))
				))
			    tests)))
	      run-ids)

    (let ((updater (hash-table-ref/default  (dboard:data-get-updaters *data*) window-id #f)))
      (if updater (updater (hash-table-ref/default data get-details-sig #f))))

    (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL")
    ;; (debug:print 2 "run-changes: " run-changes)
    ;; (debug:print 2 "test-changes: " test-changes)
    (list run-changes test-changes)))

;;======================================================================
;; TESTS DATA
;;======================================================================

;; Produce a list of lists ready for common:sparse-list-generate-index
;;
(define (dcommon:minimize-test-data tests-dat)
  (if (null? tests-dat) 
      '()
      (let loop ((hed (car tests-dat))
		 (tal (cdr tests-dat))
		 (res '()))
	(let* ((test-id    (vector-ref hed 0)) ;; look at the tests-dat spec for locations
	       (test-name  (vector-ref hed 1))
	       (item-path  (vector-ref hed 2))
	       (state      (vector-ref hed 3))
	       (status     (vector-ref hed 4))
	       (newitem    (list test-name item-path (list test-id state status))))
	  (if (null? tal)
	      (reverse (cons newitem res))
	      (loop (car tal)(cdr tal)(cons newitem res)))))))
	  

;;======================================================================
;; D A T A   T A B L E S
;;======================================================================

;; Table of keys
(define (dcommon:keys-matrix rawconfig)
  (let* ((curr-row-num 1)
	 (key-vals     (configf:section-vars rawconfig "fields"))
	 (keys-matrix  (iup:matrix
			#:alignment1 "ALEFT"
			#:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL"
			;; #:scrollbar "YES"
			#:numcol 1
			#:numlin (length key-vals)
			#:numcol-visible 1
			#:numlin-visible (length key-vals)
			#:click-cb (lambda (obj lin col status)
				     (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
    ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys")
    (iup:attribute-set! keys-matrix "WIDTH0" 0)
    (iup:attribute-set! keys-matrix "0:1" "Key Name")
    ;; (iup:attribute-set! keys-matrix "WIDTH1" "100")
    ;; fill in keys
    (for-each 
     (lambda (var)
       ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
       (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)))
     key-vals)
    (iup:attribute-set! keys-matrix "WIDTHDEF" "40")
    keys-matrix))

;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
  (let* ((curr-row-num    1)
	 (key-vals        (configf:section-vars rawconfig sectionname))
	 (section-matrix  (iup:matrix
			   #:alignment1 "ALEFT"
			   #:expand "YES" ;; "HORIZONTAL"
			   #:numcol 1
			   #:numlin (length key-vals)
			   #:numcol-visible 1
			   #:numlin-visible (length key-vals)
			   #:scrollbar "YES")))
    (iup:attribute-set! section-matrix "0:0" varcolname)
    (iup:attribute-set! section-matrix "0:1" valcolname)
    (iup:attribute-set! section-matrix "WIDTH1" "200")
    ;; fill in keys
    (for-each 
     (lambda (var)
       ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
       (iup:attribute-set! section-matrix (conc curr-row-num ":0") var)
       (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var))
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
     key-vals)
    (iup:vbox
     (iup:label (if title title (conc "Settings from [" sectionname "]"))  
         	;; #:size   "5x"
         	#:expand "HORIZONTAL"
         	)
     section-matrix)))
    
;; General data
;;
(define (dcommon:general-info)
  (let ((general-matrix (iup:matrix
			 #:alignment1 "ALEFT"
			 #:expand "YES" ;; "HORIZONTAL"
			 #:numcol 1
			 #:numlin 3
			 #:numcol-visible 1
			 #:numlin-visible 3)))
    (iup:attribute-set! general-matrix "WIDTH1" "200")
    (iup:attribute-set! general-matrix "0:1" "About this Megatest area") 
    ;; User (this is not always obvious - it is common to run as a different user
    (iup:attribute-set! general-matrix "1:0" "User")
    (iup:attribute-set! general-matrix "1:1" (current-user-name))
    ;; Megatest area
    (iup:attribute-set! general-matrix "2:0" "Area")
    (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; Megatest version
    (iup:attribute-set! general-matrix "3:0" "Version")
    (iup:attribute-set! general-matrix "3:1" megatest-version)

    general-matrix))

(define (dcommon:run-stats)
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (mt:get-run-stats))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))
				(max-col-vis  (if (> max-col 10) 10 max-col))
				(numrows      1)
				(numcols      1))
			   (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
			   (iup:attribute-set! stats-matrix "NUMCOL" max-col )
			   (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
			   (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
			   (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))

			   ;; Row labels
			   (for-each (lambda (ind)
				       (let* ((name (car ind))
					      (num  (cadr ind))
					      (key  (conc num ":0")))
					 (if (not (equal? (iup:attribute stats-matrix key) name))
					     (begin
					       (set! changed #t)
					       (iup:attribute-set! stats-matrix key name)))))
				     row-indices)

			   ;; Col labels
			   (for-each (lambda (ind)
				       (let* ((name (car ind))
					      (num  (cadr ind))
					      (key  (conc "0:" num)))
					 (if (not (equal? (iup:attribute stats-matrix key) name))
					     (begin
					       (set! changed #t)
					       (iup:attribute-set! stats-matrix key name)))))
				     col-indices)

			   ;; Cell contents
			   (for-each (lambda (entry)
				       (let* ((row-name (car entry))
					      (col-name (cadr entry))
					      (value    (caddr entry))
					      (row-num  (cadr (assoc row-name row-indices)))
					      (col-num  (cadr (assoc col-name col-indices)))
					      (key      (conc row-num ":" col-num)))
					 (if (not (equal? (iup:attribute stats-matrix key) value))
					     (begin
					       (set! changed #t)
					       (iup:attribute-set! stats-matrix key value)))))
				     run-stats)
			   (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL"))))))
    (updater)
    (set! dashboard:update-summary-tab updater)
    (iup:attribute-set! stats-matrix "WIDTHDEF" "40")
    (iup:vbox
     ;; (iup:label "Run statistics"  #:expand "HORIZONTAL")
     stats-matrix)))

(define (dcommon:servers-table)
  (let* ((colnum         0)
	 (rownum         0)
	 (servers-matrix (iup:matrix #:expand "YES"
				     #:numcol 7
				     #:numcol-visible 7
				     #:numlin-visible 3
				     ))
	 (colnames       (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "State" "Transport"))
	 (updater        (lambda ()
			   (let ((servers (open-run-close tasks:get-all-servers tasks:open-db)))
			     (iup:attribute-set! servers-matrix "NUMLIN" (length servers))
			     ;; (set! colnum 0)
			     ;; (for-each (lambda (colname)
			     ;;    	 ;; (print "colnum: " colnum " colname: " colname)
			     ;;    	 (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
			     ;;    	 (set! colnum (+ 1 colnum)))
			     ;;           colnames)
			     (set! rownum 1)
			     (for-each 
			      (lambda (server)
				(set! colnum 0)
				(let* ((vals (list (vector-ref server 0) ;; Id
						   (vector-ref server 9) ;; MT-Ver
						   (vector-ref server 1) ;; Pid
						   (vector-ref server 2) ;; Hostname
						   (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
						   (vector-ref server 5) ;; Pubport
						   ;; (vector-ref server 10) ;; Last beat
						   ;; (vector-ref server 6) ;; Start time
						   ;; (vector-ref server 7) ;; Priority
						   ;; (vector-ref server 8) ;; State
						   (if (< (vector-ref server 10) 20) ;; Status (Please redo this properly!)
						       "alive"
						       "dead")
						   (vector-ref server 11)  ;; Transport
						   )))
				  (for-each (lambda (val)
					      ;; (print "rownum: " rownum " colnum: " colnum " val: " val)
					      (iup:attribute-set! servers-matrix (conc rownum ":" colnum) val)
					      (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
					      (set! colnum (+ 1 colnum)))
					    vals)
				  (set! rownum (+ rownum 1)))
				 (iup:attribute-set! servers-matrix "REDRAW" "ALL"))
			      servers)))))
    (set! colnum 0)
    (for-each (lambda (colname)
		(iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
		(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
		(set! colnum (+ colnum 1)))
	      colnames)
    (set! dashboard:update-servers-table updater) 
    ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40")
    (iup:hbox
     (iup:vbox
      (iup:button "Start"
		  ;; #:size "50x"
		  #:expand "YES"
		  #:action (lambda (obj)
			     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
					      "megatest -server - &")))
					      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
			       (system cmd))))
      (iup:button "Stop"
		  #:expand "YES"
		  ;; #:size "50x"
		  #:action (lambda (obj)
			     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
					      "megatest -stop-server 0 &")))
					      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
			       (system cmd))))
      (iup:button "Restart"
		  #:expand "YES"
		  ;; #:size "50x"
		  #:action (lambda (obj)
			     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
					      "megatest -stop-server 0;megatest -server - &")))
					      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
			       (system cmd)))))
      servers-matrix
     )))
  
;; The main menu
(define (dcommon: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)
							(iup: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
		       ;;  )					     
		       ))))

megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt
	asciidoc megatest_manual.txt
	dos2unix megatest_manual.html

clean:
	rm -f megatest_manual.html

How To Do Things
================

Tricks
------

This section is a compendium of a various useful tricks for debugging,
configuring and generally getting the most out of Megatest.

Debugging Tricks
----------------

Examining The Environment
~~~~~~~~~~~~~~~~~~~~~~~~~

During Config File Processing
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Organising Your Tests and Tasks
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
/nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa
----------------------------
[tests-paths]
1 #{get misc parent}/simplerun/tests
----------------------------

-------------------
[setup]
-------------------

The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS

-------------------
runscript main.csh
-------------------


ww30.2
cellname/LVS/cellname.LAYOUT_ERRORS

Error: text open

ww31.3
cellname/LVS/cellname.LAYOUT_ERRORS

Error: text open

<h1>The Megatest Users Manual</h1>
<span id="author">Matt Welland</span><br />
<span id="email"><tt>&lt;<a href="mailto:matt@kiatoa.com">matt@kiatoa.com</a>&gt;</tt></span><br />
<span id="revnumber">version 1.0,</span>
<span id="revdate">April 2012</span>
</div>
<div id="content">

















<div class="sect1">
<h2 id="_preface">Preface</h2>
<div class="sectionbody">
<div class="paragraph"><p>This book is organised as three sub-books; getting started, writing tests and reference.</p></div>
<div class="sect2">
<h3 id="_why_megatest">Why Megatest?</h3>
<div class="paragraph"><p>The Megatest project was started for two reasons, the first was an
immediate and pressing need for a generalized tool to manage a suite
of regression tests and the second was the fact that the author had
written or maintained several such tools at different companies over
the years and it seemed a good thing to have a single open source
tool, flexible enough to meet the needs of any team doing continuous
integrating and or running a complex suite of tests for release
qualification.</p></div>
</div>
<div class="sect2">
<h3 id="_megatest_design_philosophy">Megatest Design Philosophy</h3>
<div class="paragraph"><p>Megatest is intended to provide the minimum needed resources to make
writing a suite of tests and tasks for implementing continuous build
for software, design engineering or process control (via owlfs for
example) without being specialized for any specific problem
space. Megatest in of itself does not know what constitutes a PASS or
FAIL of a test. In most cases megatest is best used in conjunction
with logpro or a similar tool to parse, analyze and decide on the test
outcome.</p></div>
</div>
<div class="sect2">
<h3 id="_megatest_architecture">Megatest Architecture</h3>
<div class="paragraph"><p>All data to specify the tests and configure the system is stored in
plain text files. All system state is stored in an sqlite3
database. Tests are launched using the launching system available for
the distributed compute platform in use. A template script is provided
which can launch jobs on local and remote Linux hosts. Currently
megatest uses the network filesystem to call home to your master
sqlite3 database.</p></div>
</div>
</div>
</div>
<h1 id="_road_map">Road Map</h1>
<div class="paragraph"><p>Note: This road-map is tentative and subject to change without notice.</p></div>
<div class="sect2">
<h3 id="_ww32">ww32</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Rerun step and or subsequent steps from gui
</p>
</li>
<li>
<p>
Refresh test area files from gui
</p>
</li>
<li>
<p>
Clean and re-run button
</p>
</li>
<li>
<p>
Clean up STATE and STATUS handling.
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Dashboard and Test control panel are reverse order - choose and fix
</p>
</li>
<li>
<p>
Move seldom used states and status to drop down selector
</p>
</li>
</ol></div>
</li>
<li>
<p>
Access test control panel when clicking on Run Summary tests
</p>
</li>
<li>
<p>
Feature: -generate-index-tree
</p>
</li>
<li>
<p>
Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww33">ww33</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
http api available for use with Perl, Ruby etc. scripts
</p>
</li>
<li>
<p>
megatest.config setup entries for:
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
run launching (e.g. /bin/sh %CMD% &gt; /dev/null)
</p>
</li>
<li>
<p>
browser "konqueror %FNAME%
</p>
</li>
</ol></div>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww34">ww34</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Mark dependent tests for clean/rerun -rerun-downstream
</p>
</li>
<li>
<p>
On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
</p>
</li>
<li>
<p>
Fix: refresh of gui sometimes fails on last item (race condition?)
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww35">ww35</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
refdb: Add export of csv, json and sexp
</p>
</li>
<li>
<p>
Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
</p>
</li>
<li>
<p>
Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
</p>
</li>
<li>
<p>
Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
</p>
</li>
<li>
<p>
Refactor Run Summary view, currently very clumsy
</p>
</li>
<li>
<p>
Add option to show steps in Run Summary view
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww36">ww36</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Refactor guis for resizeablity
</p>
</li>
<li>
<p>
Add filters to Run Summary view and Run Control view
</p>
</li>
<li>
<p>
Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS&#8230;
</p>
</li>
<li>
<p>
Launch gates for diskspace; /path/one&gt;1G,/path/two&gt;200M,/tmp&gt;5G,#{scheme <strong>toppath</strong>}&gt;1G
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_bin_list">Bin List</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Quality improvements
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Server stutters occasionally
</p>
</li>
<li>
<p>
Large number of items or tests still has some issues.
</p>
</li>
<li>
<p>
Code refactoring
</p>
</li>
<li>
<p>
Replace remote process with true API using json (supports Web app also)
</p>
</li>
</ol></div>
</li>
<li>
<p>
Streamline the gui
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Everything resizable
</p>
</li>
<li>
<p>
Less clutter
</p>
</li>
<li>
<p>
Tool tips
</p>
</li>
<li>
<p>
Filters on Run Summary, Summary and Run Control panel
</p>
</li>
<li>
<p>
Built in log viewer (partially implemented)
</p>
</li>
<li>
<p>
Refactor the test control panel
</p>
</li>
</ol></div>
</li>
<li>
<p>
Help and documentation
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Complete the user manual (I’ve been working on this lately).
</p>
</li>
<li>
<p>
Online help in the gui
</p>
</li>
</ol></div>
</li>
<li>
<p>
Streamlined install
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Deployed version (download a location independent ready to run binary bundle)
</p>
</li>
<li>
<p>
Install Makefile (in progress, needed for Mike to install on VMs)
</p>
</li>
<li>
<p>
Added option to compile IUP (needed for VMs)
</p>
</li>
</ol></div>
</li>
<li>
<p>
Server side run launching
</p>
</li>
<li>
<p>
Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
</p>
</li>
<li>
<p>
Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
</p>
</li>
<li>
<p>
Wizards for creating tests, regression areas (current ones are text only and limited).
</p>
</li>
<li>
<p>
Fully functional built in web service (currently you can browse runs but it is very simplistic).
</p>
</li>
<li>
<p>
Wildcards in runconfigs: e.g. [p1271/9/%/%]
</p>
</li>
<li>
<p>
Gui panels for editing megatest.config and runconfigs.config
</p>
</li>
<li>
<p>
Fully isolated tests (no use of NFS to see regression area files)
</p>
</li>
<li>
<p>
Windows version
</p>
</li>
</ol></div>
</div>
<h1 id="_getting_started">Getting Started</h1>
<div class="openblock">
<div class="title">Getting started with Megatest</div>
<div class="content">
<div class="paragraph"><p>How to install Megatest and set it up for running your regressions and continuous integration process.</p></div>
</div></div>

<div class="sect1">
<h2 id="_the_second_chapter">The Second Chapter</h2>
<div class="sectionbody">
<div class="paragraph"><p>An example link to anchor at start of the <a href="#X1">first sub-section</a>.</p></div>
<div class="paragraph"><p>An example link to a bibliography entry <a href="#taoup">[taoup]</a>.</p></div>
</div>
</div>
<h1 id="_writing_tests">Writing Tests</h1>
<div class="sect1">
<h2 id="_the_first_chapter_of_the_second_part">The First Chapter of the Second Part</h2>
<div class="sectionbody">
<div class="paragraph"><p>Chapters grouped into book parts are at level 1 and can contain
sub-sections.</p></div>
</div>
</div>
<h1 id="_reference">Reference</h1>
<div class="sect1">
<h2 id="_the_first_chapter_of_the_second_part_2">The First Chapter of the Second Part</h2>
<div class="sectionbody">
<div class="paragraph"><p>Chapters grouped into book parts are at level 1 and can contain
sub-sections.</p></div>
</div>
</div>
<div class="sect1">
<h2 id="_the_testconfig_file">The testconfig File</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_setup_section">Setup section</h3>
<div class="sect3">
<h4 id="_header">Header</h4>
<div class="listingblock">
<div class="content">
<pre><tt>[setup]</tt></pre>
</div></div>
<div class="paragraph"><p>The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>runscript main.csh</tt></pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_requirements_section">Requirements section</h3>
<div class="sect3">
<h4 id="_header_2">Header</h4>
<div class="listingblock">
<div class="content">
<pre><tt>[requirements]</tt></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_wait_on_other_tests">Wait on Other Tests</h4>
<div class="listingblock">
<div class="content">
<pre><tt># A normal waiton waits for the prior tests to be COMPLETED
# and PASS, CHECK or WAIVED
waiton test1 test2</tt></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_mode">Mode</h4>
<div class="paragraph"><p>The default (i.e. if mode is not specified) is normal. All pre-dependent tests
must be COMPLETED and PASS, CHECK or WAIVED before the test will start</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>mode   normal</tt></pre>
</div></div>
<div class="paragraph"><p>The toplevel mode requires only that the prior tests are COMPLETED.</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>mode toplevel</tt></pre>
</div></div>
<div class="paragraph"><p>A item based waiton will start items in a test when the
same-named item is COMPLETED and PASS, CHECK or WAIVED
in the prior test</p></div>

<div class="listingblock">
<div class="content">
<pre><tt>mode itemmatch</tt></pre>
</div></div>
<div class="listingblock">
<div class="content">
<pre><tt># With a toplevel test you may wish to generate your list
# of tests to run dynamically
#
# waiton #{shell get-valid-tests-to-run.sh}</tt></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_run_time_limit">Run time limit</h4>
<div class="listingblock">
<div class="content">
<pre><tt>runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s</tt></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_skip">Skip</h4>
</div>
<div class="sect3">
<h4 id="_header_3">Header</h4>
<div class="listingblock">
<div class="content">
<pre><tt>[skip]</tt></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_skip_on_still_running_tests">Skip on Still-running Tests</h4>
<div class="listingblock">
<div class="content">
<pre><tt># NB// If the prevrunning line exists with *any* value the test will
# automatically SKIP if the same-named test is currently RUNNING

prevrunning x</tt></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_skip_if_a_file_exists">Skip if a File Exists</h4>
<div class="listingblock">
<div class="content">
<pre><tt>fileexists /path/to/a/file # skip if /path/to/a/file exists</tt></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_controlled_waiver_propagation">Controlled waiver propagation</h4>
<div class="paragraph"><p>If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig:
If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED</p></div>
<div class="paragraph"><p>Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>###### EXAMPLE FROM testconfig #########
# matching file(s) will be diff'd with previous run and logpro applied
# if PASS or WARN result from logpro then WAIVER state is set
#
[waivers]
# logpro_file    rulename      input_glob
waiver_1         logpro        lookittmp.log

[waiver_rules]

# This builtin rule is the default if there is no &lt;waivername&gt;.logpro file
# diff   diff %file1% %file2%

# This builtin rule is applied if a &lt;waivername&gt;.logpro file exists
# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html</tt></pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_ezsteps">Ezsteps</h3>
<div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>$MT_MEGATEST -env2file .ezsteps/${stepname}</tt></pre>
</div></div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_example_appendix">Appendix A: Example Appendix</h2>
<div class="sectionbody">
<div class="paragraph"><p>One or more optional appendixes go here at section level zero.</p></div>
<div class="sect2">

</div>
</div>
</div>
<div id="footnotes"><hr /></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br />
Last updated 2013-08-01 22:59:08 MST
</div>
</div>
</body>
</html>

The Megatest Users Manual
=========================
Matt Welland <matt@kiatoa.com>
v1.0, April 2012
:doctype: book



















[preface]
Preface
=======
This book is organised as three sub-books; getting started, writing tests and reference.

Why Megatest?
~~~~~~~~~~~~~

The Megatest project was started for two reasons, the first was an
immediate and pressing need for a generalized tool to manage a suite
of regression tests and the second was the fact that the author had
written or maintained several such tools at different companies over
the years and it seemed a good thing to have a single open source
tool, flexible enough to meet the needs of any team doing continuous
integrating and or running a complex suite of tests for release
qualification.

Megatest Design Philosophy
~~~~~~~~~~~~~~~~~~~~~~~~~~

Megatest is intended to provide the minimum needed resources to make
writing a suite of tests and tasks for implementing continuous build
for software, design engineering or process control (via owlfs for
example) without being specialized for any specific problem
space. Megatest in of itself does not know what constitutes a PASS or
FAIL of a test. In most cases megatest is best used in conjunction
with logpro or a similar tool to parse, analyze and decide on the test
outcome.

Megatest Architecture
~~~~~~~~~~~~~~~~~~~~~

All data to specify the tests and configure the system is stored in
plain text files. All system state is stored in an sqlite3
database. Tests are launched using the launching system available for
the distributed compute platform in use. A template script is provided
which can launch jobs on local and remote Linux hosts. Currently
megatest uses the network filesystem to call home to your master
sqlite3 database.

include::../plan.txt[]
include::getting_started.txt[]
include::writing_tests.txt[]
include::howto.txt[]
include::reference.txt[]





























[appendix]
Example Appendix
================
One or more optional appendixes go here at section level zero.

Appendix Sub-section

Reference
=========

The First Chapter of the Second Part
------------------------------------
Chapters grouped into book parts are at level 1 and can contain
sub-sections.

The testconfig File
-------------------

Setup section
~~~~~~~~~~~~~

Header
^^^^^^

-------------------
[setup]
-------------------

The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS

-------------------
runscript main.csh
-------------------

Requirements section
~~~~~~~~~~~~~~~~~~~~

Header
^^^^^^

-------------------
[requirements]
-------------------

Wait on Other Tests
^^^^^^^^^^^^^^^^^^^

-------------------
# A normal waiton waits for the prior tests to be COMPLETED 
# and PASS, CHECK or WAIVED
waiton test1 test2
-------------------

Mode
^^^^

The default (i.e. if mode is not specified) is normal. All pre-dependent tests
must be COMPLETED and PASS, CHECK or WAIVED before the test will start

-------------------
mode   normal
-------------------

The toplevel mode requires only that the prior tests are COMPLETED.

-------------------
mode toplevel
-------------------

A item based waiton will start items in a test when the
same-named item is COMPLETED and PASS, CHECK or WAIVED
in the prior test

-------------------
mode itemmatch
-------------------

-------------------

# With a toplevel test you may wish to generate your list 
# of tests to run dynamically
#
# waiton #{shell get-valid-tests-to-run.sh}
------------------



Run time limit
^^^^^^^^^^^^^^

-----------------
runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
-----------------

Skip
^^^^

Header
^^^^^^

-----------------
[skip]
-----------------

Skip on Still-running Tests
^^^^^^^^^^^^^^^^^^^^^^^^^^^

-----------------
# NB// If the prevrunning line exists with *any* value the test will 
# automatically SKIP if the same-named test is currently RUNNING

prevrunning x
-----------------

Skip if a File Exists
^^^^^^^^^^^^^^^^^^^^^

-----------------
fileexists /path/to/a/file # skip if /path/to/a/file exists
-----------------

Controlled waiver propagation
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig:
If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED

Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)

-----------------
###### EXAMPLE FROM testconfig #########
# matching file(s) will be diff'd with previous run and logpro applied
# if PASS or WARN result from logpro then WAIVER state is set
#
[waivers]
# logpro_file    rulename      input_glob
waiver_1         logpro        lookittmp.log

[waiver_rules]

# This builtin rule is the default if there is no <waivername>.logpro file
# diff   diff %file1% %file2%

# This builtin rule is applied if a <waivername>.logpro file exists
# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html
-----------------

Ezsteps
~~~~~~~

To transfer the environment to the next step you can do the following:

----------------------------
$MT_MEGATEST -env2file .ezsteps/${stepname}	  
----------------------------

:numbered!:

<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<!-- Created with Inkscape (http://www.inkscape.org/) -->

<svg
   xmlns:dc="http://purl.org/dc/elements/1.1/"
   xmlns:cc="http://creativecommons.org/ns#"
   xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
   xmlns:svg="http://www.w3.org/2000/svg"
   xmlns="http://www.w3.org/2000/svg"
   xmlns:xlink="http://www.w3.org/1999/xlink"
   xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
   xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
   width="744.09448819"
   height="1052.3622047"
   id="svg2"
   version="1.1"
   inkscape:version="0.48.3.1 r9886"
   sodipodi:docname="megatest-about.svg">
  <defs
     id="defs4">
    <linearGradient
       inkscape:collect="always"
       id="linearGradient4210">
      <stop
         style="stop-color:#000000;stop-opacity:1;"
         offset="0"
         id="stop4212" />
      <stop
         style="stop-color:#000000;stop-opacity:0;"
         offset="1"
         id="stop4214" />
    </linearGradient>
    <linearGradient
       inkscape:collect="always"
       xlink:href="#linearGradient4210"
       id="linearGradient4216"
       x1="32.261719"
       y1="719.68437"
       x2="599.57812"
       y2="719.68437"
       gradientUnits="userSpaceOnUse" />
  </defs>
  <sodipodi:namedview
     id="base"
     pagecolor="#ffffff"
     bordercolor="#666666"
     borderopacity="1.0"
     inkscape:pageopacity="0.0"
     inkscape:pageshadow="2"
     inkscape:zoom="0.7"
     inkscape:cx="263.11623"
     inkscape:cy="534.40312"
     inkscape:document-units="px"
     inkscape:current-layer="layer1"
     showgrid="false"
     inkscape:window-width="1527"
     inkscape:window-height="1016"
     inkscape:window-x="215"
     inkscape:window-y="35"
     inkscape:window-maximized="0" />
  <metadata
     id="metadata7">
    <rdf:RDF>
      <cc:Work
         rdf:about="">
        <dc:format>image/svg+xml</dc:format>
        <dc:type
           rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
        <dc:title></dc:title>
      </cc:Work>
    </rdf:RDF>
  </metadata>
  <g
     inkscape:label="Layer 1"
     inkscape:groupmode="layer"
     id="layer1">
    <rect
       style="opacity:0.78378378000000004;fill:#d6d6d6;fill-opacity:1;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
       id="rect4442"
       width="651.42859"
       height="675.71442"
       x="32.857143"
       y="330.93362" />
    <flowRoot
       xml:space="preserve"
       id="flowRoot2985"
       style="fill:black;stroke:none;stroke-opacity:1;stroke-width:1px;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;font-family:Sans;font-style:normal;font-weight:normal;font-size:72px;line-height:125%;letter-spacing:0px;word-spacing:0px"><flowRegion
         id="flowRegion2987"><rect
           id="rect2989"
           width="628.57141"
           height="104.28571"
           x="55.714287"
           y="40.933609"
           style="font-size:72px" /></flowRegion><flowPara
         id="flowPara2991"></flowPara></flowRoot>    <text
       xml:space="preserve"
       style="font-size:22px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="187.14285"
       y="58.076473"
       id="text2993"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan2995"
         x="187.14285"
         y="58.076473"
         style="font-size:64px;font-style:normal;font-variant:normal;font-weight:bold;font-stretch:normal;font-family:Sans;-inkscape-font-specification:Sans Bold">Megatest</tspan></text>
    <text
       xml:space="preserve"
       style="font-size:22px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="195.71429"
       y="100.93362"
       id="text2997"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan2999"
         x="195.71429"
         y="100.93362">Simple - but not TOO simple!</tspan></text>
    <image
       y="7.3621907"
       x="4.3571429"
       id="image3139"
       xlink:href="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAIkAAABGCAYAAAD4mreoAAAABHNCSVQICAgIfAhkiAAAIABJREFU
eJzlnXlcVNX7x98zwwwwgGyCiiuuWaYlaiq5b6m5p6aJ+S1NzbVyV9zKLbdEzQy3rIxMcV/ScM3S
cKtMUElFEVBW2QYYmPv7484dL+MMDAou/T6v133NPfes997PnPOc53nOuQpBEPhPQ4ECUAMa42Fv
DCvNDpXxF8Bg4cg3HjnGIxfIReA//gBB8Z8iiUgILeAEOPKAEIpSqlEA9IikyQYygSwEDKVU31PB
800SBUoekEJrPEqLELZCAHRABg9I8xw/5OeRJGJv4QK4Gn+VhWd46hAQyZICpD2PhHk+SCISwwmR
GGUQ5YcSwUhGtj7L2dFS2BffbVvZGlJS5ZshH7gPpCKQVUp1lDiebZIosAM8jIddaVTRnOZfp5Pe
TAqrUcec4UwXNepCH8z/+F/nCCL6VaTi0S50OfI+78cUs+ocIBWRMPpHaPoTw7NJEgX2gCfgjhUZ
Q4dO6YjjYwmIm9jks5SlB83raE/7YctZfrqwvC1osTSV1I5S2B77KG+8jzShybHpTL9UFMnMkAEk
IJBZrBt4Qni2SKLACSiLKGs8hLWsrbKXvZ0TSWySSWYDQLDDLtkb70NjGLOxK12Ti1NdV7qOvsWt
4ebX3XE/dIITn1jLp0evaEazXTnk+FqKt8MuwQOPY3Wpe2QSk/6oQpVcG5uUAdxFQGdj+ieCZ4Mk
Ys9RAXC2FB1KqFcQQR8nkdQFK4KqEmVGb3oPm8WsS7ZUmUaashWtDueR5w3ghtvhVFI7iM1R5C1g
QbuiSPcpn754mtNt73K3XQ45Na20K6sMZU754nt0DGOONqZxhg3Nuw/cQyDHlnspbTzdmYECFQoq
ADWxQpD5zK/7KZ+GJJH0JoW014DBeSc7V53ilMVeyBxTmNJCIogSZcZCFs5SoUoDEBDs1rGuR1Fl
BBJ4eR/7Vp3lbK9qVFttpV3aVFI7XODC/AMcqFpUmcM079VHFNBroqAiCtS23E9p4umQRIECBZ5A
bUTZw6LcEU648za2BUkvEzB44bXtLd4aEExws570fMce+ygALdqLAxk4zB//dFua8Bd/9ZHOPfE8
5I9/uieeB6Vrt7jVR4/eZp1LIomNpHMt2gt++E12x/2gEmUGgB1296Yy9XJhZXSt2qHjqTK/tzQG
FYgyWW0UlDfqhJ4KSmXGUCgUOAKVELWhhWIKUz7Woy8vZlPkdKPb0HnMuyjFN6XpX8MY1n8hC5ut
YMUJW4XFUEK90kiTXgaNabwboDnNd+1kZz+AXHKrTmVq4yUs+aOo8k5wokwmmSaSVKLS4U1s2g/s
v8c9uwUsaHSf+26W2hdOuHM00dobTlGaE1mnxl9I/KunWRIFopxWBgW3n4a88uRkEvE/6QV4Y4NW
9Ba3NN3o9qsBgyNAbWov3s72zUXlCyXU6zjHa61gxW/W0vSgx9DrXB8HoEZ95wxnOksv0A+/vbnk
VgXwwOPAcY5PKqrOd3m363nOL5TC4xnf2dYpcUc6To4nvvfNitfyG9s1WRQWfXxXIckFIAFxJvTE
hMkn04WJ46ovUA4b1ebLWOYnEQRgOMP3WEubTLJqOMPbvs7rK2cz+/Axji25wQ2LPZUevSKGmN5S
uAIV9sr/4RWpaHpJKaS0CyPMrai23uBGW+ncHvsoWwmymMW14okfkFA7VmvvonFJjc4YOo5xzQvJ
okD8k/miQGNLHSWB0h9uFLgCPhRTS5pEkiSHoEJ1vyMdU8zTrGBF9QMc6BVPfPd88j2k6wKCy1zm
tt3IxgPmeaYwpUkuuZWlcBxxXZvQpCXiv9RgwKCVlaNZzeru7WhntQe7xS3Nfe77S2FvvI/aeo/b
2T79fvlklaF6Dh6Hfcglt9oRjqxtQYuw93n/8yEMibWSVYso2MYh8NBzKWmUXk8iCqcVgcqYEWQ+
8+vakD1fOjdgcL7EJUd5fCSRDhvYEHKHO0PkBJFwhSvmYzsAZznbRx7Wo6+kQ1dXh+5FHbp6OeRU
l8ff4tZbhbVzMYubGDA4SeEmNLGJJEMY0iXJIdHPrm8W6igtjvmO96W4VFLbLWPZ7jd5c6S1HhHx
3VVEQRUUJWemsFZRyUNsdDVE6dyEW9zStKb1vBBCfviIj5oWVkRZyiZI5wKCaj3rG8jjX+CFbA88
fharU+S6437QHfdDUnw66U1DCCknzxNGmFsKKe2Kcys55PhOYUpDa/GXudxGOrfDLmE604vU05zn
vNN5zk/I7pBMfoIC9yjvlCCCutSn/kwVqhQAAcE+mugP+9Bn1whGtCmkuDKIw0+pjQolTxJxrKyO
aJAzYR/7PPrSd30SSd0FBNURjiwrbLwfyciLChQmTeWf/NnJPE072m2pQ52FQQS1PcGJiW/zdpAs
WrmFLQV0HV/yZTcBQSM2U5G7mtX+f/P3y+bHPvb5qVCZ/tmnOd3XUhv16BXJJLeWwu64H7dlhjWN
aSMSXo3xKv+xA0KYI6/wypKWtEz7nu93rGZ11/KU34Lo6IQefcVTnApqTvM1wQRXtlKkA1DDqJQs
cZQsSRRoEQlSoLGLWVwrkMAfssh6RUymyG1AgwXtaJdqraha1MpxxjlcCieQ0HsVq6rJ08xgRsQ2
tn3fmtb3AZxx1itQZEvxccR1kKePJtoksLrierwlLdMs1V2FKrleeO2VwskkdzjBiTLm6eYxr55M
h0Nd6hY51KxgRfVL1S4Orr5Zy53AbMonVLz4Ld/uluL98U8/zOEFAQT0dcLpvHQ9nfTmccQ91AYZ
1EB1o4qhRFFyJFFQBnGIKdDtjWRk6+/47js9eh8AO+ySutP9vc1stjpbkdCc5hvkbd3ClmmxxFrU
QJ7mtHMQQasFBAfpmi++odJ5IIH15arzl3ip0Po70MGUV0CwDyKou3maP/jDNAwoUeomMOFMUff0
peeqpR4zUKb9qkd7zh0duhe70nV0JJEO8nSTmHT1NKff9cNvsh1297zxDp3JzH+KKF6FOPTYpHW2
FSWjJxEJUhmz6W0vev0viqjxGMnogMOVcYwbM4hBcfJ0evQKa910M5oFZ5Bhkl+ccDobSOAncrvK
cIa3DSd8qqR4AyhL2V2HOBQolduXvgNuc7sjgBJlzk52jvbGO6+w22pFq0XZZFcy1vvvEY7MlMc3
otEOiXhuuIWd5OT4wsrrquk8IGJw+DTfFc5ENsnA458Kpjg16vhXeXXxetYfMs/3J39qdeiUTWlq
i90HxJnaHQSs9tTFweOTRGRtFWQEiSVW/Q7vzEok0SQTuOJ65Cu+mlKPeiaNoR69ogc9RuvQeR/l
aKCl4vexzyOQwB+knsgIgyOOkSpU6Tp0tcxnN954b93L3nmP60pQGIIJrhxE0H4p3IAGM77jO6uK
sIMcdH2/1cCjL4a5qm+MzcDhy3JJlai0K5bYAAHB1Ds643ymH/0WfMRH/5ZAM+MQSHrcQh5vuBFN
+wUIcpCD7r3pvU5OkEpUWneUo+PlBIkk0qEtbZfd5vYHiST27EnP9yxV0ZWuye/y7kh77K/L261D
92IGGa/JCaJEmf4Kr8wII+zT0iQIgAGDwguvHXbYJQGGwQw+UVj64fWHfFvrR2e1LjqP7N0qGtJw
yUEOLh/BiF4uuJyS0mWQ8dpGNm7vSMeJ4YRbNHoWAxWMeqrHwqP3JKKQWg0zojWn+dp00k1aQw88
9h/n+GR5mhBCyi1l6cpssiV9iaEudRduZesP1qq7xjX7sYz98C53u8iHFcRe5Up5yh8OJPAHG03x
JQY9esVKVtb4mI+jrKVpWPulT1SrU4a4t7fn8hv3qfBzjYvhhAfI0xiHzMnyHrM61VfsYtc6S2Xq
0CmHMrRHHHH1NWjS61DntBVThADceBx3yUcjiQIHRDX7Q0qcL/my6lrW/mDAIAlPhla0GrWKVb8C
zGRm/T3sWZFHXlkQzfStaDUhiKBT5mVZw3KW10gm2UmBgk50umGr5fdp4L0K7zb8beSB4CqBTpqk
XdkkD9YIH6SN6DeVqZHmaa9xzX4844fe5vb/7LBL3M72Hr74PuRTspzlNUIImZtFVn35dQccIgYw
YJoFwuYD/yJgq/NTARSfJKKirCZY93P4iI+ahhH2lYCgApEIQxk68Bzn6p7n/FwBwR5Ag+b2YAaP
Hse46+ZlFCbMPi/YwQ63j/oP+6l2iEt5IU/gn9fS8DpfOase9RZsYtMua/e3nvWVbnDD8zM++9M8
7h737DrTeUcuudUs5VWgyG5N6/EW/nS5iETJt5SvMBSPJKLkUQ0rDkJy9KPf2xFETJfCKlSp+eSb
lGdOOJ2bx7zxlnQls5n98j72zbI0E3pekEmmsl6r6sHV9zk2UTkpiJ6VITDPQ6HJF+1yjjj+3ZWu
8231pJMQQED3i1ycJ4W98f5Jg+Z+LLFvGzA4g+gN15e+Q2YwI+KhZsHN4lqQiyu4lsMGggBsZWtI
OcqZZAw5Qbzw2rGb3UMtEWQIQ7qEEroxm+w6K1ix+k/+1JqnKQI+QGdEdTVAQ0CurW0LvGw8tzem
7UhBtAEay8ryksX5Gq85G8vqLDtqGNN07P9SzzWV1qobqZwU6BPzMexxPOSd731YKkSH7uVtbNvS
lrZzDnKwgPmiMKSSapJZ1Kjjwwibe4ADK1ayspMrrkdB9IbbzvYvze1diFrwirbWJcF2koi6EK8i
08mwla2LXHD5XX7NEcfLRzgy01xHoUev6ErX0ec4t0gajpQodTHEFFAy2QBX4HOglTE8B1iCOAtz
A75AJABAO2PapYB8fJ8BDDOeLwLekcVNACYCWcBs4DNgsvFoDhDivmXR/QnRzR3rqJUAOWPdcrZd
2LPqJCc/bk/7YbKZmiKBhN6TmbzvLd56J5nkIg11csOnHr33Slb6ArSkZdpMZs6SbD955JVdxCJz
8gO4oaBsUfXIYRtJRHtMAQZ2pOPk7nT/QIfOahkeeOQvZvEnGjQ3pWs6dC+aT3eN0+Glcs91Dzz2
hRDyXnE94IEriF7njRANjFWAaOBV46EAJO+2HkAU4vqXbhbKigX+ALrwwJ3QH9gHpvW+p4HWxuPb
edp5VVf3W6hyHCIupckMz8sfePh9+wY0+AhgOctP72d/n1rUWqJEmQlgwOByhStTOtJx22Qm+8kb
8Bmf1U0jzfSMW9DimCxa+SM/mhR4HemY4o67aSp+gxvtrTyjcsWx8xRNEnH1XAFz/0hGto4jbtAN
boxpQ5uNm9nsYy27P/7pH/DBKLnB7F/+HTeSka1BnA4HELBZ8lQHhOpUX3Gc41MsSfY2wIBIAj+g
AfAvcNwYfhVRgLuE6LzTFNgDHEYcLiwJ47sQPfn9gDeMz0GuNGsKHAOOJZLYPrjNF587rE436Y3u
zMz+Z1Ti2Gs86L3wxjsvlNBv5jL3TU889yBOU8khp+YNbtSS0kUS6bCd7Ws60tH0jCcy8VoZyvwq
pbnP/bbTmPaqLGxyo1SgsLboS4HoZmATbOlJPOGB0SiUUK/f+X2uFM4ks+FSlm4fwpAu1goYzvBb
7Wn/sayrVP7GbwsDCOixiEUhkr5EiTLLH/9x1nQDxcA5oCrQAThvDDdEfNGXEYnSDfH+pbW6roi9
gTl+QRxa3jQeEYi9j4QoYC4wt3WTpr2qbXR8UWH8O93dqEttd+7NIAWKsoi9WwH0oEfiMY5N60a3
dx1wiHDAIeIbvtkqxU9net888jwzyWy4jGU/nee8E8AgBi2UE+AXfpmsR6/QoVM642wShJ1wul3I
M9KCbcNO4SQR3Q5NVk49esUSlszLJ7+AoGXA4HyOc4ta03qBNS3hEpb88SIvzpPlcbrIxc8kfYka
dew7vBPwFV/Z7NlVCM4Zf7sCF4xHFeAl4zlAT8QX1xuRHDlYHnJ0wCFjWfWB3WbxeUB6v9o9W7ks
1TXVeIkMyc8UcFldMWZ9wsb+iMPUDmuNnc/8Cyc48fZUpo6Sa4oTSawnnTvh9FdDGmYCjGRkdBWq
mP5IOnQvDWFID0ccDSc4MaEGNZarUKWNYcw3hTwjAG9b3CCL6kl85GniiFPnkScngaBEaVK1J5H0
5nCGb5/O9FcsFRZCyE/lKf+9+XUt2guf8umASUy6WlSDbcQlxJeuQiRFCnBdFq6POJUPQiRGN+BH
oAVmjlJG7ET02chHlEfkqH9Se3JD7OCrvV1e15geuH6CKz+d21sFkZwLgLWFNdgRR0NveifIr+WS
azI5uOFWwAL8NV8HS8tJAC5zebz0B93Jzg3zmNfNXJ5LJlnVgQ5TZJ6BkndbobBOEoVpawcTqlAl
dwpTxtlhd1dKpUX7lzPOJhO5Hr3PbnZ/05WuoyxJ69vZ/rkLLqYxtSxld+1gx/uPIKAWBj2i4Poy
ovAJYs/xMnAU+Mt4LjcDLEaUWVIQZz0fyOLOGdO/YoyX0HIb21oO6dP7unb6g5UOuuv5htRfszdU
oII/8BZgciIqDrRoTQ7VGWRUksf54KNvSUuTh34eeZ4b2GCSR8yfZzjhzm/y5pp44t/5iZ9WbWWr
NEI4IYoUVmGZJKJWtYKlqN70TuhL3zGSc08GGa+VpezZmtRcJhsnlbe4NaIznTevZ32BmytDGcMy
lk20xz6qFrWWHOXoDB98nulV9daQSaZyYutRS6t95VTALzZmku7qnkuHVj1u+c1otlM6TyGl/Rzm
1JPHz2NeuBJlliyNVRWFG256aRTII897MYtXyfQo5QpbKWitJ/GiEE/6aUyLeI3XpmKUym9y80N3
3OP60e8d+XQ3i6z6QQRtCyCggMNOU5pm7GZ3v1BCixozn2k0blR/WsWvNX4q7YP+Onl/TlbdP+qv
r0rVxyb+Z3z2pyuuR0B0fNrBji/HMOZ1KX4Sk5rLvftzybXqlVaLWjmBBI5Ro44DyCa77ghGfG5U
YSiRyZ7meJgkD/YEKRTBBP/ii+9KKddZzn6WQ476e77v6433NimdUUCd15KWi+XrdJ/X3kNCx9qt
ujtOyuqsrWVneoZCnkDi5/l/778ddrCwvMXBRjZOcsTxb4B88t2PcWxNYxpva0SjHcc4tkaW1NCe
9scLK6sb3ZIGMGCUpJ+5z/3WPegxwRjtZq03sdSTeErXd7GrrB9++9vSdvZUpj7kMb6b3cGeeO4F
kel72LPyNKc9wgib44//WBUqk9o9hZQ3xjAmNJTQYmltHxdztHOqta3+eu+iUxajTJc51W71jBzl
2dehgM9p7JKse++GD5tnLd+joBa1cmYxa7QWrTQrI5vsOua7GFSm8roP+TC6qPImMvFaferPl8Jx
xAX0p39/RN2JxXdT0MAnyiJ1AKUevaIVrdakk25aeKRBc8sHn9196btnMINjQVwm0Ze+G7LIagDi
CrZVrApoStOMUEK9lrBknrSTkBtuv5zk5Ee2PJySwBztnGqbeq9cae+j1IwLCnx3ZPaY+Mct82/+
tu/eve23NXc411XI/mK5CfnEvaEMvXL+5qzHrcMSkklWBRAwMoaYAPkQo0CRX5nK63ayc7UtVvPP
+bx2CCGrzX1yWtN61EpWngSumu+8ZE6SchjZ1Ic+g69ydaKVugRnnMNrUnPXZCYfjibaMZDAED36
CgAuuPy2l70feuCRr0ev6E//gJvcHLCMZW9Lnu2lDYkgNTe5VBPyBa53zjlz/Ujc0Mctt2azil9U
3q1qpy5bcOJ2/b2M6xs3hg5sQYtS3a3oGMdcN7HJP4mkKlq0Kb3odext3r5bdE4YzegWJzm5RE4y
CUqUGYMZHPAJn/yBQIGVgw9IIutFFrKwzha2bJHWqADYYZeYR54HZkOUEmWWBx6HPfGMuMa1cdL6
XW+8t4YR9qmULpZY9ZOSQ+QEkbSf6Wf1uYYh3qvO/HN+46OW2+jl+sPt1iYNK9NMU8DukX5WnysM
rPDF6Wvh3z5ey0sPfek7MJLIycjeXxnKHBcQNFJPr0YdF0jggF70OoWAyQArf+EmWaQSldK0aAv4
OeST71aOcj9Wo9pqNeo70nUDBm0iiT2ucGWKfIH3Pe7160OfwVK4MIJ82fjLqn7D/fb4Dffb0/iD
xls7BXSasKbJmqoAwY2CK/sN99vTaHijXYdqHDIpuiZ0mtDE/33/1a+OePVYo+GNdg3uPbgbQJeW
Xd5Z33fFT3KCALg0Umvud4vpv9p+hcWpfVEY7DOoSc7Qe2+bEwQgfnpuxO/XNK+B354HR3ejnuWd
nmK4xbIHOTZUFK8NMC4hfW0ztC2VYSqNNGUHOkyLJHIqsvddgQrf/cIvY1ew4mNJKadHX2EBC1ad
4ESBRWBiJnEGZ/L3GMSguKMc/Z8vvisle4uAYHeXuwMSSGg6nvHvtaf9MHfcD8pX2ZnjKlc/Gc3o
163FS8i0z9TkqnKrueS6XPJN8Q2963y317f1v50OsLPOzh56pb5CjiqnWnCj4M5SnmNVj00FlP63
/We8kPDCBnW+OueG+w3785rfJ9RZ7+qgsGB0rzRHW3FJ8/mfPhxTOH7kR/dTnQ7NqDDW8SFbx931
upQ25zovU5BTCQQN1PxWPOoZF5Zdexv05SG1A6ytYrxjDeRWA51R8M2tAtnlzct+XJznvFNnOq+O
J36A7LKhLnXnHeLQIkccDY1pnDGWsaOMDt0YMDjFEFNg2ajELCcoqMN3xNGwm91f96HPIA2aW9L1
TDL9lrJ0233uu53gxMTlLG9Xm9qfy1XEDwpX5rzACzZvXemR5RGxbu+6rZo8zS2dna6mTq1TxjnH
dXPLcTvunOt8NrpMdHcAvVqvMCgNTjl2OT53ne9WeSPqjT/W71p/KM0+TaV1dTUk/5JtUbup1Cgo
/7n61SZ1X7XomW8JqaQqJ7cdu9x3tfahTfTyMwxkrlOd3ZD0zfmHc5ZNh2U1QfcS1AoCRS7sfmiB
V2nhO76rMJzh36aRZvqTKlFmtKHNh+b71A5mcGxPeo52xfXoKlYNHMjAezxw2jKRxKpn1CxmXdrA
hr5eeJkMVAYMLuGEL25N63nuuOu3s/3bs5zt1YMeg7zw2iHZc+pRb8FoRt+09caue1wf3nJIy5PZ
6uwXfFN9v5nRdkZjvUrvUzeh7j7fVN/9OrXupeVNl9dQ69VCp6hOU9T56oQrnlcmLXp90cHuA7t/
0CC+QdYb2V0+vrs6L0vQWxb0XRqpNWndY/t/Yb/EqnuDHM0bvRpY+Wv7V5WODxs4YmbpYmadXiib
8uZ5wvV+4nGpBhzqIZJj4g5wPQFx3SjGFluPijnMqbeUpVuyyTa5HahRxw5mcIA1h/NZzLr0K7+O
lS0AMy3FUBr34ipsjSkNaJB1hCMzm9L0Y7lfSBJJ3YcydFsggfVB1BAe4cjMjWxs44//2O/53qrl
0xLcde5HW0a3nLRp16bXQ0NCvzlX4VwPgLM+ZydEekZ+AHCo5qHuAL0jel/9fd3vQ9fsXdPCUe94
+Y7Lne73XO7ZTfxt4ulRYeP631mUlWitnkpzHX1WNFv8WVHtaV+nZQ/HaTmdHGuoHtIn6aLyDQ4/
exwMIEC2+MnhGoS/JR5fHIa7bwIKGPUDpPuB3gem+5mXVZIYytCO29m+SbKuA2jR/jWHOQM/4ROr
yz4swEkacuwQGWOTh1owwYe3svXP5Syfn0HGayDu77GLXZsvcvGr7/n+6zKUMTSkYeajmPzdde5X
g/aLTD9f8bxTsmNyhzI5ZX6tnVR7N0CEV8Tb8c7xb+rUuhVDuw89XCanzO8qg0qXY5dTo1xGue2/
VP+l7OfNPt/qmuN6WverOjPnTn5Z+4oPCydKjYLyi9UNGg9uMDQ84k+LviuzXGb5xvS+8mGVXlqL
62pvT8q+8ts/py3uuChi6uuQVxYqrYPyRuv2+dkQ3gMqb3g4fdbL0NQ486p4FBu2/jLHUIZ2PMOZ
JcgWy7njfmg966fVotajOHC5Akmq2cz2oZDlEeZ4iZcy3+XdPWGE6VJIaYTxOzGppDYJIaSpGvWZ
V3ilWOtgUu1TueZ5LfvlhJfD295oexdgZ92dPvec7mV2+rfTlsWHF5/pGdkzKtot+nqmOjPTI8fj
31xV7p+ZmkxHBQrhhcQXtkw+NXl7w/iGaRFlI27r1Dqtm73nnZtHYsp69tZYfMn2PipVwq2UKrln
haPN8guu27nABYepXcZ+6bvWqbrCwuCQvCc3w3fdy8tGpI269uDqL4DnP/CWcYfFA5WBW7AiGN6L
hJ5R8Hs8qHTwxl9wJVsUbtvFw8+AcyRoY8Wj0lXoWqT21ByVqBR/kIOt88jzBKhM5eADHPjMC69C
1zwXAhWzSVEICM6Iw40LxSALiDsWhRK6SL4zcjWqrd7Dnq8esVElik7V23VJXhMx272jvUXDlyFX
IKpT1rmrx2L+p0FjEmJq+PsEVdmlbqP2fLiDFfQCUe2zf79xIv6DhyKfAWxms89ylm9+iZdWFrY2
uRi4Yq5xdUQkSxlEJ5siEUmkwyhGTbrHvb6OOF46yMFBHngUewFQaaF6mwrBNX62b6pQW5YX08/q
c3MDPNaei/zrawC/+vVHar5Oft/lNbVFR+GY+Vn3+s8b/v6srLk3S6/Vj4drXLN/xOHFEuKtL84S
LYJSD+NEEbsmjmBEmwY0uD6SkcXuJksTi7TzK2+atmJT5elaq6bwm5MzYoet+OT9C+UuVP570vEF
FUY5WnTCyb2XT/wbqm2RF27MKb0WP3PQ2baCT1TZS8OSMyX4vZkngXp+Nad67sodYF9RZZHohlyB
K20yL9q/iFv1YOdq1sr5d0jGv999s3tgM5o9N9+qeURIX//KBDIeZS2w9IEiaVh66nufF4UoojSd
BjYPqfG9Uy1raTIj9YJjNTuF0sHKsHRGn6MY5LP8t6g/HvLR/Y8gmwefhMuUf0ewJDaxceDBsFTi
+3WVFN6o0a5L0qqIWe5v2Bd32SgIcLVT5sWrh2MGywXc5xw5GHsKRFJYlSMff880gWwE7iHwL+Lq
uVhjxc/Uwzz4b9j+pMXCn9Y0sYXhbrAupcPZN5c+5wTRI65UjAGuIHDMvDIRAAACvUlEQVQNgVgE
0oraaaBkd18U0COQjMBNxEVMt40NeyZmOyPPjJt7Z5HOJt8LCfkZBjI32IUHp2y4WHTqZwp5iN/N
iUV0JLqCQAxC8T/n9mQ+QPDge73SsPTE9kU3x8t+taa478we6FDJziYbys2PMm/P/uKLQQMZWJJL
PkoDBuTDB2SXVF/+dL6cJcoxkuD7ROWYKKI0nQY0/6HGFqfaRaXNupZnyOjpvO7i5YiVRaV9CpCW
p0rEyC6tL1c8nQ/tiHJMglGOiUTsEtN5AnJMTWrm1jndIDjlYE6R09g7E7Ov7L8ctqaodE8IAuKa
5ATgBnAZgZvG56grzU+bPBvf4JMgWqTlZoJS08fUaFt+bfWDDs2taWKTd+VkVBhVb+aeO4cOW0zw
ZGB1Wvok8Wx9nVvAYJS2YxB7mBtAIjzahnCFYcSZ8Z/eWWhZiBX0AklLDX89BYLkAMnALSACgSgE
4hFIf1oEgWeNJHIICAhkGh/SVeAacBdK5svcEzOnxCh3uh7Kjsl7qCuNWai7N/SPD+dbylfCeORp
6ZPEszXc2ArRGUYSfJ14RLJHE61uM7DxDzW/d6ojXcuNzye+s91PkRevzy0s7yMiD7mw+YhbZj5p
PLs9SWEQyEMgBYFoxGEpGnG1f7H8JqpSVf/C768EJx94IMTenqSL+vbij4tLqKUGRIE8DnGzm0gE
bht1Sc8FQeB57UmsQZRBtTzoZWzaF6xG2wpf+R6w9884p89RDaq09NT1M1Z3pi4C8mlpJpTurONJ
4b9FEnOIu/hIMyUtVtwdvrBf4vPVtMWbs08KcTd/uRdgKY0VFLCWAln/BVKY479NEjlEdweph3HG
bKh9sXatiS0TWv/8VUrwX0WU9ExMS58k/v+QRA7RTODMA9IU9v06m62l/1X8/ySJHOIA5EhBBZ6c
FM/1Piolgf8Do6DT7EsG7IgAAAAASUVORK5CYII=
"
       height="70"
       width="137" />
    <text
       xml:space="preserve"
       style="font-size:28px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="78.571426"
       y="139.50505"
       id="text3142"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan3144"
         x="78.571426"
         y="139.50505">Automation</tspan></text>
    <text
       xml:space="preserve"
       style="font-size:28px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="208.57144"
       y="185.21931"
       id="text3146"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan3148"
         x="208.57144"
         y="185.21931">Quality Assurance</tspan></text>
    <text
       xml:space="preserve"
       style="font-size:28px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="310"
       y="230.93361"
       id="text3150"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan3152"
         x="310"
         y="230.93361">Regression Testing</tspan></text>
    <text
       xml:space="preserve"
       style="font-size:28px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="401.42856"
       y="283.79074"
       id="text3154"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan3156"
         x="401.42856"
         y="283.79074">System Administration</tspan></text>
    <rect
       style="opacity:0.84942082;fill:#000000;fill-opacity:0.05608335;stroke:#2b0000;stroke-width:3;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
       id="rect3158"
       width="40"
       height="41.42857"
       x="24.285707"
       y="110.93362" />
    <rect
       style="opacity:0.84942082;fill:#000000;fill-opacity:0.05608335;stroke:#2b0000;stroke-width:3;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
       id="rect3158-5"
       width="40"
       height="41.42857"
       x="147.14287"
       y="155.93361" />
    <rect
       style="opacity:0.84942082;fill:#000000;fill-opacity:0.05608335;stroke:#2b0000;stroke-width:3;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
       id="rect3158-9"
       width="40"
       height="41.42857"
       x="258.57141"
       y="201.64792" />
    <rect
       style="opacity:0.84942082;fill:#000000;fill-opacity:0.05608335;stroke:#2b0000;stroke-width:3;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
       id="rect3158-50"
       width="40"
       height="41.42857"
       x="347.14282"
       y="253.07646" />
    <rect
       style="opacity:0.84942082;fill:#000000;fill-opacity:0.05608335;stroke:#2b0000;stroke-width:3;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
       id="rect3402"
       width="0"
       height="0"
       x="687.14282"
       y="729.50494" />
    <text
       xml:space="preserve"
       style="font-size:28px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="81.428574"
       y="390.93362"
       id="text4402"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan4404"
         x="81.428574"
         y="390.93362">Write one task or test and iterate</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="425.93362"
         id="tspan4406">Distribute tasks over one or many hosts</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="460.93362"
         id="tspan4408">Organize runs by any variables you wish</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="495.93362"
         id="tspan4410"> - release</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="530.93359"
         id="tspan4412"> - architecture</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="565.93359"
         id="tspan4414"> - unit or partition</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="600.93359"
         id="tspan4416">Tasks or tests may depend on others</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="635.93359"
         id="tspan4418">Each task or test runs in clean area</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="670.93359"
         id="tspan4420">Add disk space or partitions as needed</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="705.93359"
         id="tspan4422">Rigorous results; error, pass, warn etc.</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="740.93359"
         id="tspan4424">Crontab friendly runs (skip if running)</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="775.93359"
         id="tspan4426">Easy debugging</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="810.93359"
         id="tspan4428"> - easy to recreate environment for task</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="845.93359"
         id="tspan4430"> - annotated HTML logs help find issues</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="880.93353"
         id="tspan4432">Simplify scripts</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="915.93353"
         id="tspan4434"> - eliminate for-each or while loops</tspan><tspan
         sodipodi:role="line"
         x="81.428574"
         y="950.93353"
         id="tspan4436"> - parallel running handled by tool</tspan></text>
    <rect
       style="opacity:0.7837838;fill:#e81c1c;fill-opacity:1;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
       id="rect4444"
       width="95.714287"
       height="38.57143"
       x="17.142857"
       y="223.79076" />
    <text
       xml:space="preserve"
       style="font-size:28px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="31.428562"
       y="253.79076"
       id="text4446"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan4448"
         x="31.428562"
         y="253.79076">FAIL</tspan></text>
    <rect
       style="opacity:0.7837838;fill:#1ac92c;fill-opacity:1;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
       id="rect4444-6"
       width="92.85714"
       height="40"
       x="19.285711"
       y="177.36217" />
    <text
       xml:space="preserve"
       style="font-size:28px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="29.285706"
       y="208.79076"
       id="text4446-1"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan4448-6"
         x="29.285706"
         y="208.79076">PASS</tspan></text>
    <rect
       style="opacity:0.7837838;fill:#ffbf02;fill-opacity:1;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
       id="rect4444-9"
       width="95.714287"
       height="38.57143"
       x="17.857157"
       y="268.79077" />
    <text
       xml:space="preserve"
       style="font-size:28px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
       x="22.142862"
       y="295.93362"
       id="text4446-3"
       sodipodi:linespacing="125%"><tspan
         sodipodi:role="line"
         id="tspan4448-9"
         x="22.142862"
         y="295.93362">WARN</tspan></text>
  </g>
</svg>

Road Map
========

Note: This road-map is tentative and subject to change without notice.

ww32
~~~~

. Rerun step and or subsequent steps from gui
. Refresh test area files from gui
. Clean and re-run button
. Clean up STATE and STATUS handling.
.. Dashboard and Test control panel are reverse order - choose and fix
.. Move seldom used states and status to drop down selector
. Access test control panel when clicking on Run Summary tests
. Feature: -generate-index-tree
. Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2

ww33
~~~~

. http api available for use with Perl, Ruby etc. scripts
. megatest.config setup entries for:
.. run launching (e.g. /bin/sh %CMD% > /dev/null)
.. browser "konqueror %FNAME%

ww34
~~~~

. Mark dependent tests for clean/rerun -rerun-downstream
. On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
. Fix: refresh of gui sometimes fails on last item (race condition?)

ww35
~~~~

. refdb: Add export of csv, json and sexp
. Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
. Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
. Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
. Refactor Run Summary view, currently very clumsy
. Add option to show steps in Run Summary view

ww36
~~~~

. Refactor guis for resizeablity
. Add filters to Run Summary view and Run Control view
. Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
. Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G

Bin List
~~~~~~~~

.	Quality improvements
..	Server stutters occasionally
..	Large number of items or tests still has some issues.
..	Code refactoring
..	Replace remote process with true API using json (supports Web app also)
.	Streamline the gui
..	Everything resizable
..	Less clutter
..	Tool tips
..	Filters on Run Summary, Summary and Run Control panel
..	Built in log viewer (partially implemented)
..	Refactor the test control panel
.	Help and documentation
..	Complete the user manual (I’ve been working on this lately).
..	Online help in the gui
.	Streamlined install
..	Deployed version (download a location independent ready to run binary bundle)
..	Install Makefile (in progress, needed for Mike to install on VMs)
..	Added option to compile IUP (needed for VMs)
.	Server side run launching
.	Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
.	Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
.	Wizards for creating tests, regression areas (current ones are text only and limited).
.	Fully functional built in web service (currently you can browse runs but it is very simplistic).
.	Wildcards in runconfigs: e.g. [p1271/9/%/%]
.	Gui panels for editing megatest.config and runconfigs.config
.	Fully isolated tests (no use of NFS to see regression area files)
.	Windows version

;; 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.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils)
(import (prefix sqlite3 sqlite3:))

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(define (ezsteps:run-from testdat start-step-name run-one)
  (let* ((test-run-dir  (db:test-get-rundir testdat))
	 (testconfig    (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
	 (ezstepslst    (hash-table-ref/default testconfig "ezsteps" '()))
	 (run-mutex     (make-mutex))
	 (rollup-status 0)
	 (exit-info     (vector #t #t #t))
	 (test-id       (db:test-get-id testdat))
	 (test-name     (db:test-get-testname testdat))
	 (kill-job      #f)) ;; for future use (on re-factoring with launch.scm code
    (let loop ((count 5))
      (if (file-exists? test-run-dir)
	  (push-directory test-run-dir)
	  (if (> count 0)
	      (begin
		(debug:print 0 "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times")
		(sleep 3)
		(loop (- count 1))))))
    (debug:print-info 0 "Running in directory " test-run-dir)
    (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
    ;; if ezsteps was defined then we are sure to have at least one step but check anyway
    (if (not (> (length ezstepslst) 0))
	(message-window "ERROR: You can only re-run steps defined via ezsteps")
	(begin
	  (let loop ((ezstep   (car ezstepslst))
		     (tal      (cdr ezstepslst))
		     (prevstep #f)
		     (runflag  #f)) ;; flag used to skip steps when not starting at the beginning
	    (if (vector-ref exit-info 1)
		(let* ((stepname  (car ezstep))  ;; do stuff to run the step
		       (stepinfo  (cadr ezstep))
		       (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
		       (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each 
		       (stepcmd   (list-ref stepparts 3))
		       (script    "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!
		       (logpro-used #f))

		  ;; Skip steps until hit start-step-name
		  ;;
		  (if (and start-step-name
			   (not runflag))
		      (if (equal? stepname start-step-name)
			  (set! runflag #t) ;; and continue
			  (if (not (null? tal))
			      (loop (car tal)(cdr tal) stepname #f))))

		  (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
			       " stepparms: " stepparms " stepcmd: " stepcmd)
		  
		  (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t))
		  
		  ;; call the command using mt_ezstep
		  (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
		  
		  (debug:print 4 "script: " script)
		  ;; DO NOT remote
		  (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: test-run-dir)
		  ;; now launch
		  (let ((pid (process-run script)))
		    (let processloop ((i 0))
		      (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
				  (mutex-lock! run-mutex)
				  (vector-set! exit-info 0 pid)
				  (vector-set! exit-info 1 exit-status)
				  (vector-set! exit-info 2 exit-code)
				  (mutex-unlock! run-mutex)
				  (if (eq? pid-val 0)
				      (begin
					(thread-sleep! 1)
					(processloop (+ i 1))))
				  ))
		    (let ((exinfo (vector-ref exit-info 2))
			  (logfna (if logpro-used (conc stepname ".html") "")))
		      ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
		      (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: test-run-dir))
		    (if logpro-used
			(cdb:test-set-log! *runremote*  test-id (conc stepname ".html")))
		    ;; set the test final status
		    (let* ((this-step-status (cond
					      ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
					      ((eq? (vector-ref exit-info 2) 0)                   'pass)
					      (else 'fail)))
			   (overall-status   (cond
					      ((eq? rollup-status 2) 'warn)
					      ((eq? rollup-status 0) 'pass)
					      (else 'fail)))
			   (next-status      (cond 
					      ((eq? overall-status 'pass) this-step-status)
					      ((eq? overall-status 'warn)
					       (if (eq? this-step-status 'fail) 'fail 'warn))
					      (else 'fail))))
		      (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used 
				   " this-step-status: " this-step-status " overall-status: " overall-status 
				   " next-status: " next-status " rollup-status: " rollup-status)
		      (case next-status
			((warn)
			 (set! rollup-status 2)
			 ;; NB// test-set-status! does rdb calls under the hood
			 (tests:test-set-status! test-id "RUNNING" "WARN" 
						 (if (eq? this-step-status 'warn) "Logpro warning found" #f)
						 #f))
			((pass)
			 (tests:test-set-status! test-id "RUNNING" "PASS" #f #f))
			(else ;; 'fail
			 (set! rollup-status 1) ;; force fail
			 (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f)
			 ))))
		  (if (and (steprun-good? logpro-used (vector-ref exit-info 2))
			   (not (null? tal)))
		      (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop
			  (loop (car tal) (cdr tal) stepname runflag))))
		(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))
	  
	  ;; Once done with step/steps update the test record
	  ;;
	  (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
		 (testinfo  (cdb:get-test-info-by-id *runremote* test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
	    ;; Am I completed?
	    (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		(let ((new-state  (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
				  ;; "COMPLETED"
				  ;; (db:test-get-state testinfo)))   ;; else preseve the state as set within the test
				  )
		      (new-status (cond
				   ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run
				   ((eq? rollup-status 0)
				    ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO)
				    (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS"))
				   ((eq? rollup-status 1) "FAIL")
				   ((eq? rollup-status 2)
				    ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
				    (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
				   (else "FAIL")))) ;; (db:test-get-status testinfo)))
		  (debug:print-info 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
		  (tests:test-set-status! test-id 
					  new-state
					  new-status
					  (args:get-arg "-m") #f)
		  ;; need to update the top test record if PASS or FAIL and this is a subtest
		  (if (not (equal? item-path ""))
		      (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status))))
	    ;; for automated creation of the rollup html file this is a good place...
	    (if (not (equal? item-path ""))
		(tests:summarize-items #f run-id test-id test-name #f)) ;; don't force - just update if no
	    )))
    (pop-directory)
    rollup-status))

;; Single record for managing a filedb
;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
;; Filedb record
(define (make-filedb:fdb)(make-vector 5))
(define-inline (filedb:fdb-get-db          vec)    (vector-ref  vec 0))
(define-inline (filedb:fdb-get-dbpath      vec)    (vector-ref  vec 1))
(define-inline (filedb:fdb-get-pathcache   vec)    (vector-ref  vec 2))
(define-inline (filedb:fdb-get-idcache     vec)    (vector-ref  vec 3))
(define-inline (filedb:fdb-get-partcache   vec)    (vector-ref  vec 4))
(define-inline (filedb:fdb-set-db!         vec val)(vector-set! vec 0 val))
(define-inline (filedb:fdb-set-dbpath!     vec val)(vector-set! vec 1 val))
(define-inline (filedb:fdb-set-pathcache!  vec val)(vector-set! vec 2 val))
(define-inline (filedb:fdb-set-idcache!    vec val)(vector-set! vec 3 val))
(define-inline (filedb:fdb-set-partcache!  vec val)(vector-set! vec 4 val))

;; children records, should have use something other than "child"
(define-inline (filedb:child-get-id vec)       (vector-ref vec 0))
(define-inline (filedb:child-get-path vec)     (vector-ref vec 1))
(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))

;; Copyright 2006-2011, 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-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
(import (prefix sqlite3 sqlite3:))

(declare (unit filedb))

(include "fdb_records.scm")
;; (include "settings.scm")

(define (filedb:open-db dbpath)
  (let* ((fdb      (make-filedb:fdb))
	 (dbexists (file-exists? dbpath))
	 (db (sqlite3:open-database dbpath)))
    (filedb:fdb-set-db!        fdb db)
    (filedb:fdb-set-dbpath!    fdb dbpath)
    (filedb:fdb-set-pathcache! fdb (make-hash-table))
    (filedb:fdb-set-idcache!   fdb (make-hash-table))
    (filedb:fdb-set-partcache! fdb (make-hash-table))
    ;(sqlite3:set-busy-timeout! db 1000000)
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = OFF;")
	  (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
	  (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
	  ;; NB// We store a useful subset of file attributes but do not attempt to store all
	  (sqlite3:execute db "CREATE TABLE paths (id        INTEGER PRIMARY KEY,
                                                   path      TEXT,
                                                   parent_id INTEGER,
                                                   mode      INTEGER DEFAULT -1,
                                                   uid       INTEGER DEFAULT -1,
                                                   gid       INTEGER DEFAULT -1,
                                                   size      INTEGER DEFAULT -1,
                                                   mtime     INTEGER DEFAULT -1);")
	  (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
	  (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT,                  updated TIMESTAMP);")))
    fdb))

(define (filedb:finalize-db! fdb)
  (sqlite3:finalize! (filedb:fdb-get-db fdb)))

(define (filedb:get-current-time-string)
  (string-chomp (time->string (seconds->local-time (current-seconds)))))

(define (filedb:get-base-id db path)
  (let ((stmt   (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
        (id-num #f))
    (sqlite3:for-each-row 
     (lambda (num) (set! id-num num)) stmt path)
    (sqlite3:finalize! stmt)
    id-num))

(define (filedb:get-path-id db path parent)
  (let ((stmt   (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
        (id-num #f))
    (sqlite3:for-each-row 
     (lambda (num) (set! id-num num)) stmt path parent)
    (sqlite3:finalize! stmt)
    id-num))

(define (filedb:add-base db path)
  (let ((existing (filedb:get-base-id db path)))
    (if existing #f
        (begin
          (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))

;; index 	value 	field 	notes
;; 0 	inode number 	st_ino 	
;; 1 	mode 	st_mode 	bitfield combining file permissions and file type
;; 2 	number of hard links 	st_nlink 	
;; 3 	UID of owner 	st_uid 	as with file-owner
;; 4 	GID of owner 	st_gid 	
;; 5 	size 	st_size 	as with file-size
;; 6 	access time 	st_atime 	as with file-access-time
;; 7 	change time 	st_ctime 	as with file-change-time
;; 8 	modification time 	st_mtime 	as with file-modification-time
;; 9 	parent device ID 	st_dev 	ID of device on which this file resides
;; 10 	device ID 	st_rdev 	device ID for special files (i.e. the raw major/minor number)
;; 11 	block size 	st_blksize 	
;; 12 	number of blocks allocated 	st_blocks 	

(define (filedb:add-path-stat db path parent statinfo)
  (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
	(sqlite3:execute stmt
			 path
			 parent
			 (vector-ref statinfo 1) ;; mode
			 (vector-ref statinfo 3) ;; uid
			 (vector-ref statinfo 4) ;; gid
			 (vector-ref statinfo 5) ;; size
			 (vector-ref statinfo 8) ;; mtime
			 )
	(sqlite3:finalize! stmt))) ;;  (filedb:get-current-time-string))))
  
(define (filedb:add-path db path parent)
  (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
    (sqlite3:execute stmt path parent)
    (sqlite3:finalize! stmt)))

(define (filedb:register-path fdb path #!key (save-stat #f))
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (pathcache (filedb:fdb-get-pathcache fdb))
	 (stat      (if save-stat (file-stat path #t)))
	 (id        (hash-table-ref/default pathcache path #f)))
    (if id id 
        (let ((plist (string-split path "/")))
          (let loop ((head (car plist))
                     (tail (cdr plist))
                     (parent 0))
            (let ((id (filedb:get-path-id db head parent))
                  (done (null? tail)))
              (if id          ;; we'll have a id if the path is already registered
                  (if done 
                      (begin
                        (hash-table-set! pathcache path id)
                        id) ;; return the last path id for a result
                      (loop (car tail)(cdr tail) id))
                  (begin      ;; add the path and then repeat the loop with the same data
		    (if save-stat
			(filedb:add-path-stat db head parent stat) 
			(filedb:add-path db head parent))
                    (loop head tail parent)))))))))

(define (filedb:update-recursively fdb path #!key (save-stat #f))
  (let ((p  (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
    (print "processed 0 files...")
    (let loop ((l  (read-line p))
               (lc 0)) ;; line count
      (if (eof-object? l) 
	  (begin
	    (print "          " lc " files")
	    (close-input-port p))
          (begin
            (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
            (if (= (modulo lc 100) 0)
                (print "          " lc " files"))
            (loop (read-line p)(+ lc 1)))))))

(define (filedb:update fdb path #!key (save-stat #f))
  ;; first get the realpath and add it to the bases table
  (let ((real-path path) ;; (filedb:get-real-path path))
	(db        (filedb:fdb-get-db    fdb)))
    (filedb:add-base db real-path)
    (filedb:update-recursively fdb path save-stat: save-stat)))

;; not used and broken
;;
(define (filedb:get-real-path path)
  (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
         (pth (read-line p)))
    (if (eof-object? pth) path
	(begin
	  (close-input-port p)
	  pth))))

(define (filedb:drop-base fdb path)
  (print "Sorry, I don't do anything yet"))

(define (filedb:find-all fdb pattern action)
  (let* ((db     (filedb:fdb-get-db fdb))
	 (stmt   (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
	 (result '()))
    (sqlite3:for-each-row 
     (lambda (num)
       (action num)
       (set! result (cons num result))) stmt pattern)
    (sqlite3:finalize! stmt)
    result))

(define (filedb:get-path-record fdb id)
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (partcache (filedb:fdb-get-partcache fdb))
	 (dat (hash-table-ref/default partcache id #f)))
    (if dat dat
	(let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
	      (result #f))
	  (sqlite3:for-each-row 
	   (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
	  (hash-table-set! partcache id result)
	  (sqlite3:finalize! stmt)
	  result))))

(define (filedb:get-children fdb parent-id)
  (let* ((db        (filedb:fdb-get-db fdb))
	 (res       '()))
    (sqlite3:for-each-row
     (lambda (id path parent-id)
       (set! res (cons (vector id path parent-id) res)))
     db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
     parent-id)
    res))

;; retrieve all that have children and those without
;; children that match patt
(define (filedb:get-children-patt fdb parent-id search-patt)
  (let* ((db        (filedb:fdb-get-db fdb))
	 (res       '()))
    ;; first get the children that have no children
    (sqlite3:for-each-row
     (lambda (id path parent-id)
       (set! res (cons (vector id path parent-id) res)))
     db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND 
            (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
     parent-id search-patt)
    res))

(define (filedb:get-path fdb id)
  (let* ((db      (filedb:fdb-get-db      fdb))
	 (idcache (filedb:fdb-get-idcache fdb))
	 (path    (hash-table-ref/default idcache id #f)))
    (if path path
        (let loop ((curr-id id)
                   (path    ""))
          (let ((path-record (filedb:get-path-record fdb curr-id)))
            (if (not path-record) #f ;; this id has no path
                (let* ((parent-id (list-ref path-record 1))
                       (pname     (list-ref path-record 0))
                       (newpath   (string-append  "/" pname path)))
                  (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
                      (begin
                        (hash-table-set! idcache id newpath)
                        newpath)
                      (loop parent-id newpath)))))))))

(define (filedb:search db pattern)
  (let ((action (lambda (id)(print (filedb:get-path db id)))))
    (filedb:find-all db pattern action)))

(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);; #!key (get-label #f))
  ;; ((if get-label cadr car)
   (case (string->symbol state)
     ((COMPLETED)
      (case (string->symbol status)
	((PASS)        (list "70  249 73" status))
	((WARN WAIVED) (list "255 172 13" status))
	((SKIP)        (list "230 230 0" status))
	(else (list "223 33 49" status))))
     ;;      (if (equal? status "PASS")
     ;;	  '("70 249 73" "PASS")
     ;;	  (if (or (equal? status "WARN")
     ;;		  (equal? status "WAIVED"))
     ;;	      (list "255 172 13" status)
     ;;	      (list "223 33 49"  status)))) ;; greenish orangeish redish
     ((LAUNCHED)         (list "101 123 142"  state))
     ((CHECK)            (list "255 100 50"   state))
     ((REMOTEHOSTSTART)  (list "50 130 195"   state))
     ((RUNNING)          (list "9 131 232"    state))
     ((KILLREQ)          (list "39 82 206"    state))
     ((KILLED)           (list "234 101 17"   state))
     ((NOT_STARTED)      (list "240 240 240"  state))
     (else               (list "192 192 192"  state))))

;;  PURPOSE.

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))

(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)

;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048) 

(declare (unit http-transport))

(include "db_records.scm")

(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))

;;======================================================================
;; S E R V E R
;;======================================================================

;; Call this to start the actual server

;; <html>
;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result
(define (http-transport:client-send-receive serverdat msg #!key (numretries 30))
  (let* (;; (url        (http-transport:make-server-url serverdat))
	 (fullurl    (if (list? serverdat)
			 (caddr serverdat)
			 (begin
			   (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info")
			   (exit 1)))) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg)))
	 (res        #f))
    (handle-exceptions
     exn
     (begin
       (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
       (thread-sleep! 2)
       (if (> numretries 0)

			      (set! res (with-input-from-request 
					 fullurl 
					 (list (cons 'dat msg)) 
					 read-string))
			      (close-all-connections!) 
			      (mutex-unlock! *http-mutex*)))
	      (time-out     (lambda ()
			      (thread-sleep! 45)
			      (if (not res)
				  (begin
				    (debug:print 0 "WARNING: communication with the server timed out.")
				    (mutex-unlock! *http-mutex*)
				    (http-transport:client-send-receive serverdat msg numretries: (- numretries 1))
				    (if (< numretries 3) ;; on last try just exit
					(begin