Megatest

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

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

ndboard : newdashboard.scm $(OFILES) $(GOFILES)
	csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
odboard : olddashboard.scm $(OFILES) $(GOFILES)
	csc $(OFILES) $(GOFILES) olddashboard.scm -o odboard

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

# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o  \
  archive.o megatest.o : db_records.scm
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
client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm rpc-transport.scm
client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm olddashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm rpc-transport.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 

%.o : %.scm
	csc $(CSCOPTS) -c $<

$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest
	@echo Installing to PREFIX=$(PREFIX)
	$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
	utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
	chmod a+x $(PREFIX)/bin/megatest

$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
	$(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard
$(PREFIX)/bin/.$(ARCHSTR)/odboard : odboard
	$(INSTALL) odboard $(PREFIX)/bin/.$(ARCHSTR)/odboard

$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard
	utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
	chmod a+x $(PREFIX)/bin/newdashboard
$(PREFIX)/bin/olddashboard : $(PREFIX)/bin/.$(ARCHSTR)/odboard
	utils/mk_wrapper $(PREFIX) odboard $(PREFIX)/bin/olddashboard
	chmod a+x $(PREFIX)/bin/olddashboard

# $(HELPERS) : utils/%
# 	$(INSTALL) $< $@
# 	chmod a+x $@

$(PREFIX)/bin/mt_laststep : utils/mt_laststep
	$(INSTALL) $< $@

	utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
	chmod a+x $(PREFIX)/bin/dashboard
	$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/mt_xterm \
          $(PREFIX)/bin/newdashboard
          $(PREFIX)/bin/olddashboard

$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)

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

    ))

;; These are called by the server on recipt of /api calls
;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;;    - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
(define (api:execute-requests dbstruct area-dat dat)
  (handle-exceptions
   exn
   (let ((call-chain (get-call-chain)))
     (print-call-chain (current-error-port))
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))       
     (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
   (if (not (vector? dat))                    ;; it is an error to not receive a vector

		    (string->symbol cmd))

	    ;;===============================================
	    ;; READ/WRITE QUERIES
	    ;;===============================================

	    ;; SERVERS
	    ((start-server)                    (apply server:kind-run params))
	    ((start-server)                    (apply server:kind-run params area-dat))
	    ((kill-server)                     (set! *server-run* #f))

	    ;; TESTS
	    ((test-set-state-status-by-id)     (apply db:test-set-state-status-by-id dbstruct params))
	    ((delete-test-records)             (apply db:delete-test-records dbstruct params))
	    ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
	    ((test-set-status-state)           (apply db:test-set-status-state dbstruct params))
	    ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
	    ((roll-up-pass-fail-counts)        (apply db:roll-up-pass-fail-counts dbstruct params))
	    ((update-fail-pass-counts)         (apply db:general-call dbstruct 'update-pass-fail-counts params))
	    ((test-set-archive-block-id)       (apply db:test-set-archive-block-id dbstruct params))
	    ((test-set-state-status-by-id)     (apply db:test-set-state-status-by-id dbstruct area-dat params))
	    ((delete-test-records)             (apply db:delete-test-records dbstruct area-dat params))
	    ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct area-dat params))
	    ((test-set-status-state)           (apply db:test-set-status-state dbstruct area-dat params))
	    ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct area-dat params))
	    ((roll-up-pass-fail-counts)        (apply db:roll-up-pass-fail-counts dbstruct area-dat params))
	    ((update-fail-pass-counts)         (apply db:general-call dbstruct area-dat 'update-pass-fail-counts params))
	    ((test-set-archive-block-id)       (apply db:test-set-archive-block-id dbstruct area-dat params))

	    ;; RUNS
	    ((register-run)                 (apply db:register-run dbstruct params))
	    ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct params))
	    ((delete-run)                   (apply db:delete-run dbstruct params))
	    ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct params))
	    ((update-run-event_time)        (apply db:update-run-event_time dbstruct params))
	    ((register-run)                 (apply db:register-run dbstruct area-dat params))
	    ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct area-dat params))
	    ((delete-run)                   (apply db:delete-run dbstruct area-dat params))
	    ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct area-dat params))
	    ((update-run-event_time)        (apply db:update-run-event_time dbstruct area-dat params))

	    ;; STEPS
	    ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))
	    ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct area-dat params))

	    ;; TEST DATA
	    ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
	    ((csv->test-data)               (apply db:csv->test-data dbstruct params))
	    ((test-data-rollup)             (apply db:test-data-rollup dbstruct area-dat params))
	    ((csv->test-data)               (apply db:csv->test-data dbstruct area-dat params))

	    ;; MISC
	    ((sync-inmem->db)               (let ((run-id (car params)))
					      (db:sync-touched dbstruct run-id force-sync: #t)))
	    ((mark-incomplete)              (apply db:find-and-mark-incomplete dbstruct params))
					      (db:sync-touched dbstruct area-dat run-id force-sync: #t)))
	    ((mark-incomplete)              (apply db:find-and-mark-incomplete dbstruct area-dat params))

	    ;; TESTMETA
	    ((testmeta-add-record)       (apply db:testmeta-add-record dbstruct params))
	    ((testmeta-update-field)     (apply db:testmeta-update-field dbstruct params))
	    ((testmeta-add-record)             (apply db:testmeta-add-record dbstruct area-dat params))
	    ((testmeta-update-field)           (apply db:testmeta-update-field dbstruct area-dat params))

	    ;; TASKS
	    ((tasks-add)                 (apply tasks:add dbstruct params))   
	    ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
	    ((tasks-add)                       (apply tasks:add dbstruct area-dat params))   
	    ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct area-dat params))

	    ;; ARCHIVES
	    ;; ((archive-get-allocations)   
	    ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
	    ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
	    ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
	    ((archive-register-disk)     (apply db:archive-register-disk dbstruct area-dat params))
	    ((archive-register-block-name)(apply db:archive-register-block-name dbstruct area-dat params))
	    ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct area-dat block-id testsuite-name areakey))

	    ;;======================================================================
	    ;; READ ONLY QUERIES
	    ;;======================================================================

	    ;; KEYS
	    ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct params))
	    ((get-keys)                        (db:get-keys dbstruct))
	    ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct area-dat params))
	    ((get-keys)                        (db:get-keys dbstruct area-dat))

	    ;; ARCHIVES
	    ((test-get-archive-block-info)     (apply db:test-get-archive-block-info dbstruct params))
	    ((test-get-archive-block-info)     (apply db:test-get-archive-block-info dbstruct area-dat params))
	    
	    ;; TESTS
	    ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
	    ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
	    ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
	    ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
	    ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
	    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
	    ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
	    ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
	    ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
	    ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
	    ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
	    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
	    ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))
	    ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
	    ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct params))
	    ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
	    ((synchash-get)                    (apply synchash:server-get dbstruct params))
	    ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct area-dat params))
	    ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct area-dat params))
	    ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct area-dat params))
	    ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct area-dat params))
	    ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct area-dat params))
	    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct area-dat params))
	    ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct area-dat params))
	    ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct area-dat params))
	    ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct area-dat params))
	    ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct area-dat params))
	    ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct area-dat params))
	    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct area-dat params))
	    ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct area-dat params))
	    ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct area-dat params))
	    ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct area-dat params))
	    ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct area-dat params))
	    ((synchash-get)                    (apply synchash:server-get dbstruct area-dat params))

	    ;; RUNS
	    ((get-run-info)                 (apply db:get-run-info dbstruct params))
	    ((get-run-status)               (apply db:get-run-status dbstruct params))
	    ((set-run-status)               (apply db:set-run-status dbstruct params))
	    ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct params))
	    ((get-test-id)                  (apply db:get-test-id dbstruct params))
	    ((get-tests-for-run-mindata)    (apply db:get-tests-for-run-mindata dbstruct params))
	    ((get-runs)                     (apply db:get-runs dbstruct params))
	    ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
	    ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
	    ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
	    ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
	    ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
	    ((get-run-info)                 (apply db:get-run-info dbstruct area-dat params))
	    ((get-run-status)               (apply db:get-run-status dbstruct area-dat params))
	    ((set-run-status)               (apply db:set-run-status dbstruct area-dat params))
	    ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct area-dat params))
	    ((get-test-id)                  (apply db:get-test-id dbstruct area-dat params))
	    ((get-tests-for-run-mindata)    (apply db:get-tests-for-run-mindata dbstruct area-dat params))
	    ((get-runs)                     (apply db:get-runs dbstruct area-dat params))
	    ((get-all-run-ids)              (db:get-all-run-ids dbstruct area-dat))
	    ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct area-dat params))
	    ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct area-dat params))
	    ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct area-dat params))
	    ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct area-dat params))

	    ;; STEPS
	    ((get-steps-data)               (apply db:get-steps-data dbstruct params))
	    ((get-steps-for-test)           (apply db:get-steps-for-test dbstruct params))
	    ((get-steps-data)               (apply db:get-steps-data dbstruct area-dat params))
	    ((get-steps-for-test)           (apply db:get-steps-for-test dbstruct area-dat params))

	    ;; MISC
	    ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
	    ((login)                        (apply db:login dbstruct params))
	    ((have-incompletes?)            (apply db:have-incompletes? dbstruct area-dat params))
	    ((login)                        (apply db:login dbstruct area-dat params))
	    ((general-call)                 (let ((stmtname   (car params))
						  (run-id     (cadr params))
						  (realparams (cddr params)))
					      (db:with-db dbstruct run-id #t ;; these are all for modifying the db
					      (db:with-db dbstruct area-dat run-id #t ;; these are all for modifying the db
							  (lambda (db)
							    (db:general-call db stmtname realparams)))))
							    (db:general-call db stmtname realparams area-dat)))))
	    ((sdb-qry)                      (apply sdb:qry params))
	    ((ping)                         (current-process-id))

	    ;; TESTMETA
	    ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))
	    ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct area-dat params))

	    ;; TASKS 
	    ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))))))))
	    ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct area-dat params))))))))


;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct $) ;; the $ is the request vars proc
(define (api:process-request dbstruct area-dat $) ;; the $ is the request vars proc
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
	 (params  (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj))
	 (resdat  (api:execute-requests dbstruct (vector cmd params))) ;; #( flag result )
	 (resdat  (api:execute-requests dbstruct area-dat (vector cmd params))) ;; #( flag result )
	 (res     (vector-ref resdat 1)))

    ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
    ;; (rmt:dat->json-str
    ;;  (if (or (string? res)
    ;;          (list?   res)
    ;;          (number? res)
    ;;          (boolean? res))
    ;;      res 
    ;;      (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
    (db:obj->string res transport: 'http)))

			common:get-disk-space-used  ;; if a proc call it, if a string it is a unix command
			(list testdir)))
	       (apath  (archive:get-archive testname itempath dused)))
	  (jobrunner:run-job
	   flavor
	   maxload
	   '()
	   archive:run-bup
	   archive:run-bup ;; this will break!!! need area-dat
	   (list testdir apath))))))
	  
;; Get archive disks from megatest.config
;;
(define (archive:get-archive-disks)
  (let ((section (configf:get-section *configdat* "archive-disks")))
(define (archive:get-archive-disks area-dat)
  (let ((section (configf:get-section (megatest:area-configdat area-dat) "archive-disks")))
    (if section
	section
	'())))

;; look for the best candidate archive area, else create new 
;; area
;;

;; archive - run bup
;;
;; 1. create the bup dir if not exists
;; 2. start the du of each directory
;; 3. gen index
;; 4. save
;;
(define (archive:run-bup archive-command run-id run-name tests)
(define (archive:run-bup archive-command run-id run-name tests area-dat)
  ;; move the getting of archive space down into the below block so that a single run can 
  ;; allocate as needed should a disk fill up
  ;;
  (let* ((configdat    (megatest:area-configdat area-dat))
	 (toppath      (megatest:area-path      area-dat))
  (let* ((min-space    (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
	 (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space))
	 (min-space    (string->number (or (configf:lookup configdat "archive" "minspace") "1000")))
	 (archive-info (archive:allocate-new-archive-block toppath (common:get-testsuite-name) min-space))
	 (archive-dir  (if archive-info (cdr archive-info) #f))
	 (archive-id   (if archive-info (car archive-info) -1))
	 (disk-groups  (make-hash-table))
	 (test-groups  (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
	 (bup-exe      (or (configf:lookup *configdat* "archive" "bup") "bup"))
	 (compress     (or (configf:lookup *configdat* "archive" "compress") "9"))
	 (linktree     (configf:lookup *configdat* "setup" "linktree")))
	 (bup-exe      (or (configf:lookup configdat "archive" "bup") "bup"))
	 (compress     (or (configf:lookup configdat "archive" "compress") "9"))
	 (linktree     (configf:lookup configdat "setup" "linktree")))

    (if (not archive-dir) ;; no archive disk found, this is fatal
	(begin
	  (debug:print 0 "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config")
	  (debug:print 0 "       use [archive] minspace to specify minimum available space")
	  (debug:print 0 "   disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n         "))
	  (exit 1))

	      (rmt:test-set-archive-block-id run-id test-id archive-id)
	      (if (member archive-command '("save-remove"))
		  (runs:remove-test-directory test-dat 'archive-remove))))
	  (hash-table-ref test-groups disk-group))))
     (hash-table-keys disk-groups))
    #t))

(define (archive:bup-restore archive-command run-id run-name tests)  ;; move the getting of archive space down into the below block so that a single run can 
(define (archive:bup-restore archive-command run-id run-name tests area-dat)  ;; move the getting of archive space down into the below block so that a single run can 
  ;; allocate as needed should a disk fill up
  ;;
  (let* ((configdat    (megatest:area-configdat area-dat))
  (let* ((bup-exe      (or (configf:lookup *configdat* "archive" "bup") "bup"))
	 (linktree     (configf:lookup *configdat* "setup" "linktree")))
	 (bup-exe      (or (configf:lookup configdat "archive" "bup") "bup"))
	 (linktree     (configf:lookup configdat "setup" "linktree")))

    ;; from the test info bin the path to the test by stem
    ;;
    (for-each
     (lambda (test-dat)
       ;; When restoring test-dat will initially contain an old and invalid path to the test
       (let* ((best-disk         (get-best-disk *configdat*))
       (let* ((best-disk         (get-best-disk configdat))
	      (item-path         (db:test-get-item-path test-dat))
	      (test-name         (db:test-get-testname  test-dat))
	      (test-id           (db:test-get-id        test-dat))
	      (run-id            (db:test-get-run_id    test-dat))
	      (keyvals           (rmt:get-key-val-pairs run-id))
	      (target            (string-intersperse (map cadr keyvals) "/"))
	      

all : batchsim
	./batchsim

batchsim : batchsim.scm
	csc batchsim.scm

(define (client:get-signature)
  (if *my-client-signature* *my-client-signature*
      (let ((sig (conc (get-host-name) " " (current-process-id))))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

;; Not currently used! But, I think it *should* be used!!!
(define (client:logout serverdat)
(define (client:logout serverdat area-dat)
  (let ((ok (and (socket? serverdat)
		 (cdb:logout serverdat *toppath* (client:get-signature)))))
		 (cdb:logout serverdat (megatest:area-path area-dat) (client:get-signature)))))
    ok))

(define (client:connect iface port)
  (case (server:get-transport)
(define (client:connect iface port area-dat)
  (case (server:get-transport area-dat)
    ((rpc)  (rpc:client-connect  iface port))
    ((http) (http:client-connect iface port))
    ((zmq)  (zmq:client-connect  iface port))
    (else   (rpc:client-connect  iface port))))

(define (client:setup  run-id #!key (remaining-tries 10) (failed-connects 0))
  (case (server:get-transport)
    ((rpc) (rpc-transport:client-setup run-id)) ;;(client:setup-rpc run-id))
    ((http)(client:setup-http run-id))
    (else  (rpc-transport:client-setup run-id)))) ;; (client:setup-rpc run-id))))
(define (client:setup run-id area-dat #!key (remaining-tries 10) (failed-connects 0))
  (case (server:get-transport area-dat)
    ((rpc) (rpc-transport:client-setup run-id area-dat))
    ((http)(client:setup-http run-id area-dat))
    (else  (rpc-transport:client-setup run-id area-dat))))

;; (define (client:login-no-auto-setup server-info run-id)
;;   (case (server:get-transport)
;;     ((rpc)  (rpc:login-no-auto-client-setup server-info run-id))
;;     ((http) (rmt:login-no-auto-client-setup server-info run-id))
;;     (else   (rpc:login-no-auto-client-setup server-info run-id))))
;; 
;; (define (client:setup-rpc run-id)
;;   (debug:print 0 "INFO: client:setup remaining-tries=" remaining-tries)
;;   (if (<= remaining-tries 0)
;;       (begin
;; 	(debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id)
;; 	(exit 1))
;;       (let ((host-info (hash-table-ref/default *runremote* run-id #f)))
;;       (let ((host-info (hash-table-ref/default (common:get-remote remote) run-id #f)))
;; 	(debug:print-info 0 "client:setup host-info=" host-info ", remaining-tries=" remaining-tries)
;; 	(if host-info
;; 	    (let* ((iface     (car  host-info))
;; 		   (port      (cadr host-info))
;; 		   (start-res (client:connect iface port))
;; 		   ;; (ping-res  (server:ping-server run-id iface port))
;; 		   (ping-res  (client:login-no-auto-setup start-res run-id)))
;; 	      (if ping-res   ;; sucessful login?
;; 		  (begin
;; 		    (hash-table-set! *runremote* run-id start-res)
;; 		    (hash-table-set! (common:get-remote remote) run-id start-res)
;; 		    start-res)  ;; return the server info
;; 		  (if (member remaining-tries '(3 4 6))
;; 		      (begin    ;; login failed
;; 			(debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info)
;; 			(hash-table-delete! *runremote* run-id)
;; 			(hash-table-delete! (common:get-remote remote) run-id)
;; 			(open-run-close tasks:server-force-clean-run-record
;; 			 		tasks:open-db
;; 			 		(lambda ()(tasks:open-db area-dat))
;; 			 		run-id 
;; 			 		(car  host-info)
;; 			 		(cadr host-info)
;; 					" client:setup (host-info=#t)")
;; 			(thread-sleep! 5)
;; 			(client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1)))
;; 		      (begin
;; 			(debug:print 25 "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info)
;; 			(thread-sleep! 5)
;; 			(client:setup run-id remaining-tries: (- remaining-tries 1))))))
;; 	    ;; YUK: rename server-dat here
;; 	    (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id)))
;; 	    (let* ((server-dat (open-run-close tasks:get-server (lambda ()(tasks:open-db area-dat)) run-id)))
;; 	      (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
;; 	      (if server-dat
;; 		  (let* ((iface     (tasks:hostinfo-get-interface server-dat))
;; 			 (port      (tasks:hostinfo-get-port      server-dat))
;; 			 (start-res (http-transport:client-connect iface port))
;; 			 ;; (ping-res  (server:ping-server run-id iface port))
;; 			 (ping-res  (rmt:login-no-auto-client-setup start-res run-id)))
;; 		    (if start-res
;; 			(begin
;; 			  (hash-table-set! *runremote* run-id start-res)
;; 			  (hash-table-set! (common:get-remote remote) run-id start-res)
;; 			  start-res)
;; 			(if (member remaining-tries '(2 5))
;; 			    (begin    ;; login failed
;; 			      (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
;; 			      (hash-table-delete! *runremote* run-id)
;; 			      (hash-table-delete! (common:get-remote remote) run-id)
;; 			      (open-run-close tasks:server-force-clean-run-record
;; 					      tasks:open-db
;; 					      (lambda ()(tasks:open-db area-dat))
;; 					      run-id 
;; 					      (tasks:hostinfo-get-interface server-dat)
;; 					      (tasks:hostinfo-get-port      server-dat)
;; 					      " client:setup (server-dat = #t)")
;; 			      (thread-sleep! 2)
;; 			      (server:try-running run-id)
;; 			      (thread-sleep! 10) ;; give server a little time to start up
;; 			      (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1)))
;; 			    (begin
;; 			      (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
;; 			      (thread-sleep! 5)
;; 			      (client:setup run-id remaining-tries: (- remaining-tries 1))))))
;; 		  (begin    ;; no server registered
;; 		    (if (eq? remaining-tries 2)
;; 			(begin
;; 			  ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
;; 			  ;; (open-run-close tasks:server-clean-out-old-records-for-run-id (lambda ()(tasks:open-db area-dat)) run-id " client:setup (server-dat=#f)")
;; 			  (client:setup run-id remaining-tries: 10))
;; 			(begin
;; 			  (thread-sleep! 2) 
;; 			  (debug:print 25 "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat)
;; 			  (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3)
;; 			  (if (< (open-run-close tasks:num-in-available-state (lambda ()(tasks:open-db area-dat)) run-id) 3)
;; 			      (begin
;; 				;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
;; 				;; (open-run-close tasks:server-clean-out-old-records-for-run-id (lambda ()(tasks:open-db area-dat)) run-id " client:setup (server-dat=#f)")
;; 				(server:try-running run-id)))
;; 			  (thread-sleep! 10) ;; give server a little time to start up
;; 			  (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))))

;; 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
;;   1. We are a test manager and we received transport-type and (common:get-remote remote) 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
;;      transport-type and (common:get-remote remote) from the monitor.db
;;
;; client:setup
;;
;; lookup_server, need to remove *runremote* stuff
;; lookup_server, need to remove (common:get-remote remote) stuff
;;
(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0))
(define (client:setup-http run-id area-dat #!key (remaining-tries 10) (failed-connects 0)(remote #f))
  (debug:print-info 2 "client:setup remaining-tries=" remaining-tries)
  (let* ((tdbdat (tasks:open-db)))
  (let* ((tdbdat         (tasks:open-db area-dat))
	 (transport-type (megatest:area-transport area-dat)))
    (if (<= remaining-tries 0)
	(begin
	  (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id)
	  (exit 1))
	(let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id)))
	(let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat area-dat) run-id)))
	  (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
	  (if server-dat
	      (let* ((iface     (tasks:hostinfo-get-interface server-dat))
		     (hostname  (tasks:hostinfo-get-hostname  server-dat))
		     (port      (tasks:hostinfo-get-port      server-dat))
		     (start-res (case *transport-type*
		     (start-res (case transport-type
				  ((http)(http-transport:client-connect iface port))
				  ((nmsg)(nmsg-transport:client-connect hostname port))))
		     (ping-res  (case *transport-type* 
				  ((http)(rmt:login-no-auto-client-setup start-res run-id))
				  ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id)))
		     (ping-res  (case transport-type 
				  ((http)(rmt:login-no-auto-client-setup start-res run-id area-dat))
				  ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id area-dat)))
 					   (if logininfo
 					       (car (vector-ref logininfo 1))
 					       #f))))))
		(if (and start-res
			 ping-res)
		    (begin
		      (hash-table-set! *runremote* run-id start-res)
		      (common:set-remote! remote run-id start-res)
		      (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res))
		      start-res)
		    (begin    ;; login failed but have a server record, clean out the record and try again
		      (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
		      (case *transport-type* 
		      (case transport-type 
			((http)(http-transport:close-connections run-id)))
		      (hash-table-delete! *runremote* run-id)
		      (common:del-remote! remote run-id)
		      (tasks:kill-server-run-id run-id)
		      (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat)
		      (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat area-dat)
							   run-id 
							   (tasks:hostinfo-get-interface server-dat)
							   (tasks:hostinfo-get-port      server-dat)
							   " client:setup (server-dat = #t)")
		      (if (> remaining-tries 8)
			  (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little
			  (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time
		      (server:try-running run-id)
		      (thread-sleep! 5)   ;; give server a little time to start up
		      (client:setup run-id remaining-tries: (- remaining-tries 1))
		      (client:setup run-id area-dat remaining-tries: (- remaining-tries 1))
		      )))
	      (begin    ;; no server registered
		(let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id)))
		  (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
		  (if (< num-available 2)
		      (server:try-running run-id))
		      (server:try-running run-id area-dat))
		  (thread-sleep! (+ 5 (random (- 20 remaining-tries))))  ;; give server a little time to start up, randomize a little to avoid start storms.
		  (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))
		  (client:setup run-id area-dat remaining-tries: (- remaining-tries 1)))))))))

;; keep this as a function to ease future 
(define (client:start run-id server-info)
  (http-transport:client-connect (tasks:hostinfo-get-interface server-info)
				 (tasks:hostinfo-get-port server-info)))

;; client:signal-handler

       (setenv key val))
      (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))

(define home (getenv "HOME"))
(define user (getenv "USER"))

;; GLOBAL GLETCHES
(define *db-keys* #f)
(define *configinfo* #f)
(define *configdat*  #f)
(define *toppath*    #f)
(define-record megatest:area
  name
  path
  transport
  configinfo
  configdat
  denoise
  client-signature
  remote
  )

(define *already-seen-runconfig-info* #f)
(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
(define *write-frequency*   (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f)  ;; used by -log

(define *inmemdb*             #f)
(define *task-db*             #f) ;; (vector db path-to-db)
(define *db-access-allowed*   #t) ;; flag to allow access
(define *db-access-mutex*     (make-mutex))

;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    'http)
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
(define *runremote*         (make-hash-table)) ;; if set up for server communication this will hold <host port>
;; (define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
;; (define *runremote*         (make-hash-table)) ;; if set up for server communication this will hold <host port>

(define (common:get-remote remote run-id)
  (let ((ht (or remote *runremote*)))
    (if ht
	(hash-table-ref/default ht run-id #f)
	#f)))

(define (common:set-remote! remote run-id value)
  (let ((ht (or remote *runremote*)))
    (if ht
	(hash-table-set! ht run-id value))))

(define (common:del-remote! remote run-id)
  (let ((ht (or remote *runremote*)))
    (if ht
	(hash-table-delete! ht run-id))))

(define (common:get-remote-all remote)
  (let ((ht (or remote *runremote*)))
    (if ht
	(hash-table-keys ht)
	'())))

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

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

(define (common:get-testsuite-name)
  (or (configf:lookup *configdat* "setup" "testsuite" )
       (pathname-file *toppath*)))
(define (common:get-testsuite-name area-dat)
  (or (configf:lookup (megatest:area-configdat area-dat) "setup" "testsuite" )
       (pathname-file (megatest:area-path      area-dat))))

;;======================================================================
;; E X I T   H A N D L I N G
;;======================================================================

(define (std-exit-procedure)
(define (std-exit-procedure area-dat)
  (debug:print-info 2 "starting exit process, finalizing databases.")
  (rmt:print-db-stats)
  (let ((run-ids (hash-table-keys *db-local-sync*)))
  (rmt:print-db-stats area-dat)
  (let* ((configdat (megatest:area-configdat area-dat))
	 (run-ids (hash-table-keys *db-local-sync*)))
    (if (and (not (null? run-ids))
	     (configf:lookup *configdat* "setup" "megatest-db"))
	     (configf:lookup configdat "setup" "megatest-db"))
	(db:multi-db-sync run-ids 'new2old)))
  (if *dbstruct-db* (db:close-all *dbstruct-db*))
  (if *inmemdb*     (db:close-all *inmemdb*))
  (if *dbstruct-db* (db:close-all *dbstruct-db* area-dat))
  (if *inmemdb*     (db:close-all *inmemdb* area-dat))
  (if (and *megatest-db*
	   (sqlite3:database? *megatest-db*))
      (begin
	(sqlite3:interrupt! *megatest-db*)
	(sqlite3:finalize! *megatest-db* #t)
	(set! *megatest-db* #f)))
  (if *task-db*     (let ((db (cdr *task-db*)))

(declare (uses tasks))

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

(define (control-panel db tdb keys)
  (let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove?
(define (control-panel db tdb keys area-dat)
  (let* ((toppath    (megatest:area-path area-dat))
	 (var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove?
	 (key-params (make-hash-table))
	 (monitordat '()) ;; list of monitor records
	 (keyentries (iup:frame 
		      #:title "Keys"
		      (apply
		       iup:vbox
		       (map (lambda (key)

			#:expand "YES"
			#:multiline "YES"
			#:font "Courier New, -10"
			#:value "None..............................................."))
	 (lastmodtime 0)
	 (next-touch  0) ;; the last time the "last_update" field was updated
	 (refreshdat (lambda ()
		       (let* ((monitordbpath  (conc *toppath* "/monitor.db"))
			      (megatestdbpath (conc *toppath* "/megatest.db"))
		       (let* ((monitordbpath  (conc toppath "/monitor.db"))
			      (megatestdbpath (conc toppath "/megatest.db"))
			      (modtime        (max (file-modification-time megatestdbpath)
						   (file-modification-time monitordbpath))))
			 ;; do stuff here when the db is updated by some other process
			 (if (> modtime lastmodtime)
			     (let ((tlst (tasks:get-tasks tdb '() '()))
				   (mlst (tasks:get-monitors tdb)))
			       (set! tasksdat tlst)

                 (iup:attribute-set! tabtop "TABTITLE1" "Collateral")
                 (iup:attribute-set! tabtop "TABTITLE2" "Fossil")
                 (iup:attribute-set! tabtop "TABTITLE3" "Tools")
                 tabtop))))

;; BUG: Remember to re-instate this!!!!
;; (on-exit (lambda ()
;; 	   (let ((tdb (tasks:open-db)))
;; 	   (let ((tdb (tasks:open-db area-dat)))
;; 	     ;; (print "On-exit called")
;; 	     (tasks:remove-monitor-record tdb)
;; 	     (sqlite3:finalize! tdb))))

(define (gui-monitor db)
(define (gui-monitor db area-dat)
  (let ((keys (db:get-keys db))
	(tdb  (tasks:open-db)))
	(tdb  (tasks:open-db area-dat)))
    (tasks:register-monitor db tdb) ;;; let the other monitors know we are here
    (control-panel db tdb keys)
    ;(tasks:remove-monitor-record db)
    ;(sqlite3:finalize! db)
   ))
	

;;======================================================================
;; C O M M O N
;;======================================================================

(define *dashboard-comment-share-slot* #f)

(define (dtests:get-pre-command #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
(define (dtests:get-pre-command area-dat #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "pre-command")))
    (or cfg-ovrd default-override "xterm -geometry 180x20 -e \"")))

(define (dtests:get-post-command #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
(define (dtests:get-post-command area-dat  #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "post-command")))
    (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))


(define (test-info-panel testdat store-label widgets)
  (iup:frame 
   #:title "Test Info" ; #:expand "YES"
   (iup:hbox ; #:expand "YES"

													    (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)))
														  ))))
														  ))
													    area-dat))
									  (begin
									    (rmt:test-set-state-status-by-id run-id test-id #f status #f)
									    (db:test-set-status! testdat status))))))))
				    btn))
				(map cadr *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")))
(define (dashboard-tests:run-html-viewer lfilename area-dat)
  (let ((htmlviewercmd (configf:lookup (megatest:area-configdat area-dat) "setup" "htmlviewercmd")))
    (if htmlviewercmd
	(system (conc "(" htmlviewercmd " " lfilename " ) &")) 
	(iup:send-url lfilename))))

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

					 (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 run-id testdat ovrdval cmtcmd)
  (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt"))
(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd area-dat)
  (let* ((wpatt (configf:lookup (megatest:area-configdat area-dat) "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))

					 (iup:destroy! dlog)))))))
    dlog))


;;======================================================================
;;
;;======================================================================
(define (examine-test run-id test-id) ;; run-id run-key origtest)
  (let* ((db-path       (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
	 (dbstruct      (make-dbr:dbstruct path:  (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") 
(define (examine-test run-id test-id area-dat) ;; run-id run-key origtest)
  (let* ((db-path       (db:dbfile-path run-id))
	 (dbstruct      (make-dbr:dbstruct path:  (db:dbfile-path #f)
					   local: #t))
	 (testdat       (db:get-test-info-by-id dbstruct run-id 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 (db:get-key-val-pairs dbstruct run-id) #f))
	       (rundat        (if testdat (db:get-run-info dbstruct run-id) #f))
	       (runname       (if testdat (db:get-value-by-header (db:get-rows rundat)
								  (db:get-header rundat)
								  "runname") #f))
	       (tdb           (tdb:open-test-db-by-test-id-local dbstruct run-id test-id))
	       (tdb           (tdb:open-test-db-by-test-id-local dbstruct area-dat run-id test-id))
	       ;; 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        (if testdat 
				  (db:test-get-rundir testdat)
				  logfile))
	       (testdat-path  (conc rundir "/testdat.db")) ;; this gets recalculated until found 

				   (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)
				 (dashboard-tests:run-html-viewer logfile area-dat)
				 (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)
				   (dashboard-tests:run-html-viewer lfilename area-dat)
				   (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 

					;(mutex-unlock! mx1)
							 )))))
			      lbl))
	       (store-button store-label)
	       (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10"))
	       (command-launch-button (iup:button "Execute!" #:action (lambda (x)
									(let* ((cmd     (iup:attribute command-text-box "VALUE"))
									       (fullcmd (conc (dtests:get-pre-command)
									       (fullcmd (conc (dtests:get-pre-command area-dat)
											      cmd 
											      (dtests:get-post-command))))
											      (dtests:get-post-command area-dat))))
									  (debug:print-info 02 "Running command: " fullcmd)
									  (system fullcmd)))))
	       (kill-jobs (lambda (x)
			    (iup:attribute-set! 
			     command-text-box "VALUE"
			     (conc "megatest -target " keystring " -runname "  runname 
				   " -set-state-status KILLREQ,n/a -testpatt %/% "

											   "%"
											   item-path))
						      ";megatest -target " keystring " -runname " runname 
						      " -runtests " (conc testname "/" (if (equal? item-path "")
											   "%" 
											   item-path))
						      )))
				       (system (conc (dtests:get-pre-command)
				       (system (conc (dtests:get-pre-command area-dat)
						     cmd 
						     (dtests:get-post-command))))))
						     (dtests:get-post-command area-dat))))))
	       (remove-test (lambda (x)
			      (iup:attribute-set!
			       command-text-box "VALUE"
			       (conc "megatest -remove-runs -target " keystring " -runname " runname
				     " -testpatt " (conc testname "/" (if (equal? item-path "")
									  "%"
									  item-path))

											      (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)))
										    (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%")))
										    (tdb:open-run-close-db-by-test-id-local dbstruct area-dat run-id test-id #f tdb:read-test-data 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")

;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 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)
(use format numbers)
(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:))

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses margs))
(declare (uses launch))
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses configf))
(declare (uses process))
(declare (uses launch))
(declare (uses server))
(declare (uses synchash))
(declare (uses dcommon))
(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")
(include "key_records.scm")
(include "megatest-fossil-hash.scm")

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

Usage: dashboard [options]
  -h                   : this help
  -server host:port    : connect to host:port instead of db access
  -test run-id,test-id : control test identified by testid
  -guimonitor          : control panel for runs
  -h                : this help
  -server host:port : connect to host:port instead of db access
  -test testid      : control test identified by testid
  -guimonitor       : control panel for runs

Misc
  -rows N         : set number of rows
"))

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-rows"
			"-run"
			"-test"
			"-debug"
			"-host" 
			"-transport"
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
		       )
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

;;; REMOVE ME, this is a stop-gap
(define *area-dat* (make-megatest:area
		    "default"         ;; area name
		    #f                ;; area path
		    'http             ;; transport
		    #f                ;; configinfo
		    #f                ;; configdat
		    (make-hash-table) ;; denoise
		    #f                ;; client signature
		    #f                ;; remote connections
		    ))

(if (not (launch:setup-for-run))
(if (not (launch:setup-for-run *area-dat*))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (client:launch))

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

(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbdir* (db:dbfile-path #f))
(define *dbstruct-local*  (make-dbr:dbstruct path:  *dbdir*
					     local: #t))
(define *db-file-path* (db:dbfile-path 0))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? *db-file-path*)))

(define toplevel #f)
(define dlg      #f)
(define max-test-num 0)
(define *keys*   (db:get-keys *dbstruct-local*))

(debug:setup)
(define *dbkeys*  (append *keys* (list "runname")))

(define *header*       #f)
(define *allruns*     '())
(define *tim* (iup:timer))
(define *ord* #f)
(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* (db:get-num-runs *dbstruct-local* "%"))
;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))

(iup:attribute-set! *tim* "TIME" 300)
;; 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))

(iup:attribute-set! *tim* "RUN" "YES")
(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 *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")
				     (vector "Sort +a" 'testname   "ASC")))

(define *tests-sort-type-index* '(("+testname" 0)
				  ("-testname" 1)
				  ("+event_time" 2)
				  ("-event_time" 3)
				  ("+statestatus" 4)
				  ("-statestatus" 5)))

;; 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 *tests-sort-reverse* 
  (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*)))
    (if t-sort
	(cadr t-sort)
	3)))

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

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

(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME")))

(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))
(define (iuplistbox-fill-list lb items . default)
  (let ((i 1)
	(selected-item (if (null? default) #f (car default))))
    (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
    (for-each (lambda (item)
		(iup:attribute-set! lb (number->string i) item)
		(if selected-item
		    (if (equal? selected-item item)
			(iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
			(iup:attribute-set! lb "VALUE" item))) ;; (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     (db:get-runs *dbstruct-local* 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       (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses
							  #f #f
							  *hide-not-hide*
							  sort-by
							  sort-order
							  'shortlist))
		       ;; NOTE: bubble-up also sets the global *all-item-test-names*
		       ;; (tests       (bubble-up tmptests priority: bubble-type))
		       (key-vals    (db:get-key-vals *dbstruct-local* 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"))
	 (parts        (string-split fulltestname "("))
	 (basetestname (if (null? parts) "" (car parts))))
    ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
    (if (hash-table-ref/default *collapsed* basetestname #f)
	(begin
	  ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")
	  (hash-table-delete! *collapsed* basetestname))
	(begin
	  ;(iup:attribute-set! btn "FGCOLOR" "0 192 192")
	  (hash-table-set! *collapsed* basetestname #t)))))
  
(define blank-line-rx (regexp "^\\s*$"))

(define (run-item-name->vectors lst)
  (map (lambda (x)
	 (let ((splst (string-split x "("))
	       (res   (vector "" "")))
	   (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))
	 (allvals (make-vector numcols "")))
    (for-each (lambda (name)
		(if (<= rown maxn)
		    (vector-set! allvals rown name)) ;)
		(set! rown (+ 1 rown)))
	      *alltestnamelst*)
    (let loop ((i 0))
      (let* ((lbl    (vector-ref lftcol i))
	     (keyval (vector-ref keycol i))
	     (oldval (iup:attribute lbl "TITLE"))
	     (newval (vector-ref allvals i)))
	(if (not (equal? oldval newval))
	    (let ((munged-val (let ((parts (string-split newval "(")))
				(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 (and (list? tnames)
			       (string? tname)
			       (not (member tname tnames)))
			  (set! tnames (append tnames (list tname)))))))
	      test-dats)
    tnames))

;; 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  (cond
					((member teststate '("COMPLETED" "ARCHIVED")) teststatus)
					((and (equal? teststate "NOT_STARTED")
					      (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES")))
					 teststatus)
					(else
					 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)
  (hash-table-set! *searchpatts* x val))
  (set-bg-on-filter))

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

;; mtest is actually the megatest.config file
;;======================================================================
;; 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
;;
(define (mtest window-id area-dat)
  (let* ((toppath          (megatest:area-path area-dat))
	 (curr-row-num     0)
;; referent-vals = selected value in the left dropdown
;; targets       = list of targets to use to build the dropdown
	 (rawconfig        (read-config (conc toppath "/megatest.config") #f 'return-string))
	 (keys-matrix      (dcommon:keys-matrix rawconfig))
;; 
;; each node is chained: key1 -> key2 -> key3
	 (setup-matrix     (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
	 (jobtools-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 3))
;;
;; must select values from only apropriate targets
;;   a b c
;;   a d e
;;   a b f
	 (validvals-matrix (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 2
			    #:numcol-visible 1
;;        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))
			    #:numlin-visible 2))
	 (envovrd-matrix   (iup:matrix
			    #:expand "YES"
			    #:numcol 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))
			    #:numlin 20
			    #:numcol-visible 1
			    #:numlin-visible 8))
	 (disks-matrix     (iup:matrix
		(set! val-num (+ val-num 1)))
	      values)
			    #:expand "YES"
    (let ((val (iup:attribute lb "VALUE")))
      (if val
	  val
	  (if (not (null? values))
			    #:numcol 1
			    #:numlin 20
			    #:numcol-visible 1
	      (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))
			    #:numlin-visible 8))
	 )
    (iup:attribute-set! disks-matrix "0:0" "Disk Name")
    (iup:attribute-set! disks-matrix "0:1" "Disk Path")
	 (db-target-dat (db:get-targets *dbstruct-local*))
	 (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 
    (iup:attribute-set! disks-matrix "WIDTH1" "120")
			#:size "45x50" 
			#:fontsize "10"
    (iup:attribute-set! disks-matrix "WIDTH0" "100")
			#:expand "YES" ;; "VERTICAL"
			;; #:dropdown "YES"
    (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
    (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
    (iup:attribute-set! disks-matrix "RESIZEMATRIX" "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
;;
    ;; fill in existing info
(define (dashboard:text-list-toggle-box items proc)
  (let ((alltgls (make-hash-table)))
    (apply iup:vbox
	   (map (lambda (item)
    (for-each 
     (lambda (mat fname)
		  (iup:toggle 
		   item
       (set! curr-row-num 1)
       (for-each
		   #:expand "YES"
		   #:action (lambda (obj tstate)
	(lambda (var)
			      (if (eq? tstate 0)
				  (hash-table-delete! alltgls item)
				  (hash-table-set! alltgls item #t))
	  (iup:attribute-set! mat (conc curr-row-num ":0") var)
			      (let ((all (hash-table-keys alltgls)))
				(proc all)))))
		items))))
	  (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
	  (set! curr-row-num (+ curr-row-num 1)))
	(configf:section-vars rawconfig fname)))
     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
     (list "setup"      "jobtools"      "validvalues"      "env-override" "disks"))

;; 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))
    (for-each
     (lambda (mat)
			   ""
			   (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 
       (iup:attribute-set! mat "0:1" "Value")
			    " -runtests "
			    test-patt
       (iup:attribute-set! mat "0:0" "Var")
			    " -target "
			    target
			    " -runname "
			    run-name
			    )))
      ((remove-runs)
       (set! full-cmd (conc full-cmd
       (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
			    " -remove-runs -runname "
			    run-name
			    " -target " 
			    target
			    " -testpatt "
			    test-patt
       (iup:attribute-set! mat "FIXTOTEXT" "C1")
       (iup:attribute-set! mat "RESIZEMATRIX" "YES")
			    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
       (iup:attribute-set! mat "WIDTH1" "120")
       (iup:attribute-set! mat "WIDTH0" "100")
       )
     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))

;;
(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)
  (canvas-clear! cnv)
  (canvas-font-set! cnv "Helvetica, -10")
    (iup:attribute-set! validvals-matrix "WIDTH1" "290")
  (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
    (iup:attribute-set! envovrd-matrix   "WIDTH1" "290")

    (iup:vbox
	    (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 
     (iup:hbox
	    (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)))))))
	    (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames))
	  (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames))
      ))

       
;;======================================================================
;; R U N   C O N T R O L S
      (iup:vbox
       (let ((tabs (iup:tabs 
;;======================================================================
;;
		    ;; The required tab
;; A gui for launching tests
;;
		    (iup:hbox
		     ;; The keys
(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)
		     (iup:frame 
	 (action        "-runtests")
	 (cmdln         "")
		      #:title "Keys (required)"
	 (runlogs       (make-hash-table))
	 (key-listboxes #f)
	 (updater-for-runs #f)
	 (update-keyvals (lambda ()
			   (let ((targ (map (lambda (x)
					      (iup:attribute x "VALUE"))
		      (iup:vbox
		       (iup:label (conc "Set the fields for organising your runs\n"
					"here. Note: can only be changed before\n"
					"running the first run when megatest.db\n"
					"is created."))
		       keys-matrix))
		     (iup:vbox
					    (car (dashboard:update-target-selector key-listboxes)))))
			     (dboard:data-set-target! *data* targ)
		      ;; The setup section
			     (if updater-for-runs (updater-for-runs))
			     (dashboard:update-run-command))))
		      (iup:frame
	 (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))
    
		       #:title "Setup"
    ;; 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:vbox
			(iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
					 "linktree : directory where linktree will be created."))
			setup-matrix))
		      ;; The jobtools
		      (iup:frame
		       #:title "Jobtools"
		       (iup:vbox 
			(iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
					 "useshell : use system to run your launcher\n"
					 "workhosts : spread jobs out on these hosts"))
			jobtools-matrix))
		      ;; The disks
		      (iup:frame
		       #:title "Disks"
	 (iup:toggle "Server" #:size "40x")))
       (let ((tb (iup:textbox 
		       (iup:vbox
		  #:value "megatest "
		  #:expand "HORIZONTAL"
		  #:readonly "YES"
			(iup:label (conc "Enter names and existing paths of locations to run tests")) 
		  #:font "Courier New, -12"
		  )))
			disks-matrix))))
	 (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
		    ;; The optional tab
		    (iup:vbox
      #:orientation "HORIZONTAL"
      
      (iup:split
       #:value 300

		     ;; The Environment Overrides
		     (iup:frame 
		      #:title "Env override"
		      envovrd-matrix)
       ;; Target, testpatt, state and status input boxes
       ;;
		     ;; The valid values
       (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 (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 (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f))
					    (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"
		     (iup:frame
		      #:title "Validvalues"
	   ;; 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!
	     (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
	     (lambda (all)
		      validvals-matrix)
		     ))))
	 (iup:attribute-set! tabs "TABTITLE0" "Required settings")
	 (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
	 tabs))
       ))))

;; The runconfigs.config file
;;
(define (rconfig window-id)
  (iup:vbox
   (iup:frame #:title "Default")))

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

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

(define (test-panel window-id)
  (let* ((curr-row-num 0)
	 (viewlog    (lambda (x)
	       (dboard:data-set-states! *data* all)
	       (dashboard:update-run-command))))
	   ;; Text box for STATES
	   (iup:frame
	    #:title "Statuses"
		       (if (file-exists? logfile)
					;(system (conc "firefox " logfile "&"))
			   (iup:send-url logfile)
			   (message-window (conc "File " logfile " not found")))))
	    (dashboard:text-list-toggle-box 
	     (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
	     (lambda (all)
	 (xterm      (lambda (x)
	       (dboard:data-set-statuses! *data* all)
	       (dashboard:update-run-command))))))))
      
		       (if (directory-exists? rundir)
			   (let ((shell (if (get-environment-variable "SHELL") 
       (iup:frame
	#:title "Tests and Tasks"
					    (conc "-e " (get-environment-variable "SHELL"))
	(let* ((updater #f)
	       (last-xadj 0)
	       (last-yadj 0)
	       (the-cnv   #f)
	       (canvas-obj 
                (iup:canvas #:action (make-canvas-action
				      (lambda (cnv xadj yadj)
					    "")))
			     (system (conc "cd " rundir 
					   ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
			   (message-window  (conc "Directory " rundir " not found")))))
	 (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
	 (command-launch-button (iup:button "Execute!" 
					    ;; #:expand "HORIZONTAL"
					    #:size "50x"
					(if (not updater)
					    (set! updater (lambda (xadj yadj)
					    #:action (lambda (x)
							    ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj)
							    (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)
							    (set! last-xadj xadj)
							    (set! last-yadj yadj))))
						       (let ((cmd (iup:attribute command-text-box "VALUE")))
							 (system (conc cmd "  &"))))))
					(updater xadj yadj)
					(set! the-cnv cnv)
					))
			    ;; Following doesn't work 
			    #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
					 (let ((xadj last-xadj)
					       (yadj (+ last-yadj (if (> step 0)
								      -0.01
								      0.01))))
	 (run-test  (lambda (x)
		      (iup:attribute-set! 
		       command-text-box "VALUE"
		       (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname 
			     " -runtests " (conc testname "/" (if (equal? item-path "")
								  "%" 
								  item-path))
					   ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"")
					   ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir)
					   (if the-cnv
					       (dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames))
					   (set! last-xadj xadj)
					   (set! last-yadj yadj)
					   ))
			     ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
	 (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))
			    ;; #:size "50x50"
			       " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
    	 (run-info-matrix  (iup:matrix 		            
			    #:expand "YES"
			    #:scrollbar "YES"
			    #:posx "0.5"
			    #:posy "0.5"
			    ;; #:scrollbar "YES"
			    #:numcol 1
			    #:numlin 4
			    #: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))
			    #:numcol-visible 1
			    #:numlin-visible 4
			    #:click-cb (lambda (obj lin col status)
					 (print "obj: " obj " lin: " lin " col: " col " status: " status))))
							       (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)
	 (test-info-matrix (iup:matrix
		            #:expand "YES"
		            #:numcol 1
		            #:numlin 7
								   (< 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)))
		            #:numcol-visible 1
		            #:numlin-visible 7))
	 (test-run-matrix  (iup:matrix
								       (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)
			    #:expand "YES"
								  (if updater (updater last-xadj last-yadj)))))))
						      (hash-table-keys tests-info)))))))
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
	  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")))
			    #:numlin-visible 5))
	 (meta-dat-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 5))
	 (steps-matrix     (iup:matrix
			    #:expand "YES"
			    #:numcol 6
	 (dboard:data-set-logs-textbox! *data* logs-tb)
	 logs-tb))))))


			    #:numlin 50
			    #:numcol-visible 6
;; (trace dashboard:populate-target-dropdown
;;        common:list-is-sublist)
;; 
;;       ;; key1 key2 key3 ...
;;       ;; target entry (wild cards allowed)
;;       
;;       ;; The action
;;       (iup:hbox
			    #:numlin-visible 8))
	 (data-matrix      (iup:matrix
;;        ;; label Action | action selector
;;        ))
;;      ;; Test/items selector
;;      (iup:hbox
;;       ;; tests
;;       ;; items
;;       ))
;;     ;; The command line
			    #:expand "YES"
			    #:numcol 8
			    #:numlin 50
;;     (iup:hbox
;;      ;; commandline entry
			    #:numcol-visible 8
			    #:numlin-visible 8))
;;      ;; GO button
;;      )
	 (updater          (lambda (testdat)
;;     ;; The command log monitor
;;     (iup:tabs
;;      ;; log monitor
;;      )))

			     (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;

    ;; Set the updater in updaters
    (hash-table-set! (dboard:data-get-updaters *data*) window-id updater)
    ;; 
;; General info about the run(s) and megatest area
(define (dashboard:summary db)
  (let ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
    (iup:vbox
    (for-each
     (iup:split
      #:value 500
      (iup:frame 
     (lambda (mat)
       #:title "General Info"
       (iup:vbox
	(iup:hbox
       ;; (iup:attribute-set! mat "0:1" "Value")
       ;; (iup:attribute-set! mat "0:0" "Var")
	 (iup:label "Area Path")
	 (iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
	(iup:hbox 
       (iup:attribute-set! mat "HEIGHT0" 0)
	 (dcommon:keys-matrix rawconfig)
	 (dcommon:general-info)
	 )))
      (iup:frame
       (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
       #:title "Server"
       (dcommon:servers-table)))
     (iup:frame 
      #:title "Megatest config settings"
      (iup:hbox
       ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
       (dcommon:section-matrix rawconfig "setup" "Varname" "Value")
       (iup:vbox
       (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
	(dcommon:section-matrix rawconfig "server" "Varname" "Value")
	;; (iup:frame
       ;; (iup:attribute-set! mat "WIDTH1" "120")
	;; #:title "Disks Areas"
	(dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
     (iup:frame
       ;; (iup:attribute-set! mat "WIDTH0" "100"))
      #:title "Run statistics"
      (dcommon:run-stats db)))))

     (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
;;======================================================================
;; 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)
    ;; Steps matrix
    (iup:attribute-set! steps-matrix "0:1" "Step Name")
    (iup:attribute-set! steps-matrix "0:2" "Start")
    (iup:attribute-set! steps-matrix "WIDTH2" "40")
    (iup:attribute-set! steps-matrix "0:3" "End")
    (iup:attribute-set! steps-matrix "WIDTH3" "40")
    (iup:attribute-set! steps-matrix "0:4" "Status")
    (iup:attribute-set! steps-matrix "WIDTH4" "40")
      #f))

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

    (iup:attribute-set! steps-matrix "0:5" "Duration")
    (iup:attribute-set! steps-matrix "WIDTH5" "40")
    (iup:attribute-set! steps-matrix "0:6" "Log File")
    (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
;; (define (tests window-id)
(define (dashboard:one-run db)
  (let* ((tb      (iup:treebox
    ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
    (iup:attribute-set! steps-matrix "RESIZEMATRIX" "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)
		       ))))
	 (cell-lookup (make-hash-table))
	 (run-matrix (iup:matrix
    ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
		      #:expand "YES"
		      #:click-cb
		      (lambda (obj lin col status)
			(let* ((toolpath (car (argv)))
    ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")

    ;; Data matrix
    ;; 
    (let ((rownum 1))
			       (key      (conc lin ":" col))
			       (test-id  (hash-table-ref/default cell-lookup key -1))
      (for-each
			       (cmd      (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&")))
			  (system cmd)))))
	 (updater  (lambda ()
       (lambda (x)
		     (let* ((runs-dat     (db:get-runs-by-patt db *keys* "%" #f #f #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*))
	 (iup:attribute-set! data-matrix (conc "0:" rownum) x)
			    (tests-dat    (let ((tdat (db:get-tests-for-run db run-id 
									    (hash-table-ref/default *searchpatts* "test-name" "%/%")
									    (hash-table-keys *state-ignore-hash*) ;; '()
									    (hash-table-keys *status-ignore-hash*) ;; '()
									    #f #f
									    *hide-not-hide*
									    #f #f
									    "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)
	 (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
	 (set! rownum (+ rownum 1)))
							       (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
       (list "Category" "Variable" "Value" "Expected" "Tolerance"  "Status" "Units" "Type" "Comment")))
    (iup:attribute-set! data-matrix "REDRAW" "ALL")
    
			    (numrows      1)
			    (numcols      1)
			    (changed      #f)
			    (runs-hash    (let ((ht (make-hash-table)))
					    (for-each (lambda (run)
    (for-each 
							(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)
     (lambda (data)
						  (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))))))
		       
       (let ((mat    (car data))
		       ;; (iup:attribute-set! tb "VALUE" "0")
		       ;; (iup:attribute-set! tb "NAME" "Runs")
		       ;; Update the runs tree
		       (for-each (lambda (run-id)
	     (keys   (cadr data))
	     (rownum 1))
	 (for-each
				   (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*))
	  (lambda (key)
	    (iup:attribute-set! mat (conc rownum ":0") key)
	    (set! rownum (+ rownum 1)))
	  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*)
	 (iup:attribute-set! mat "REDRAW" "ALL")))
					   ;;    		 (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))
     (list
      (list run-info-matrix  '("Run Id"  "Target"   "Runname" "Run Start Time" ))
      (list test-info-matrix '("Test Id" "Testname" "Itempath" "State"   "Status" "Test Start Time" "Comment"))
      (list test-run-matrix  '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
      (list meta-dat-matrix  '("Author"   "Owner"     "Last Reviewed" "Tags" "Description"))))
	    
    (iup:split
      #:orientation "HORIZONTAL"
      (iup:vbox
       (iup:hbox
					   ))))
				 run-ids)
	(iup:vbox
	 run-info-matrix
		       (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
		       (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
		       (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")
		       (iup:attribute-set! run-matrix "NUMCOL" max-col )
	 test-info-matrix)
       ;; test-info-matrix)
	(iup:vbox
		       (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)
	 test-run-matrix
		       ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))
		       
	 meta-dat-matrix))
		       ;; 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
       (iup:vbox
	(iup:vbox
					   (set! changed #t)
					   (iup:attribute-set! run-matrix key name)))))
	 (iup:hbox 
				 row-indices)
		       
	  (iup:button "View Log"    #:action viewlog      #:size "60x" )   ;; #:size "30x" 
		       ;; 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))
	  (iup:button "Start Xterm" #:action xterm        #:size "60x" ))	 ;; #:size "30x" 
					  (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)))
				     (hash-table-set! cell-lookup key test-id)
				     (if (not (equal? (iup:attribute run-matrix key) (cadr value)))
					 (begin
					   (set! changed #t)
					   (iup:attribute-set! run-matrix key (cadr value))
	 (iup:hbox
					   (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
				 tests-mindat)
		       
	   (iup:button "Run Test"    #:action run-test    #:size "60x" )	 ;; #:size "30x" 
		       ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.

		       (for-each (lambda (ind)
	   (iup:button "Clean Test"  #:action remove-test #:size "60x" )))	 ;; #:size "30x" 
	(iup:hbox
				   (let* ((name (car ind))
					  (num  (cadr ind))
					  (key  (conc "0:" num)))
				     (if (not (equal? (iup:attribute run-matrix key) name))
	 ;; hiup:split ;; hbox
					 (begin
					   (set! changed #t)
	 ;; #:orientation "HORIZONTAL"
	 ;; #:value 300
					   (iup:attribute-set! run-matrix key name)
					   (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))
				 col-indices)
	 command-text-box
		       (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))
    
	 command-launch-button)))
    (set! dashboard:update-run-summary-tab updater)
    (dboard:data-set-runs-tree! *data* tb)
    (iup:split
     tb
     run-matrix)))

      (iup:vbox
       (let ((tabs (iup:tabs
		    steps-matrix
		    data-matrix)))
	 (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
	 (iup:attribute-set! tabs "TABTITLE1" "Test Data")
	 tabs)))))
       
;;======================================================================
;; R U N S 
;; Test browser
;;======================================================================

(define (tests window-id)
(define (make-dashboard-buttons db nruns ntests keynames)
  (let* ((nkeys   (length keynames))
	 (runsvec (make-vector nruns))
	 (header  (make-vector nruns))
	 (lftcol  (make-vector ntests))
	 (keycol  (make-vector ntests))
	 (controls '())
	 (lftlst  '())
	 (hdrlst  '())
	 (bdylst  '())
	 (result  '())
	 (i       0))
    ;; controls (along bottom)
    (set! controls
	  (iup:hbox
	   (iup:vbox
  (iup:split
   (let* ((tb      (iup:treebox
	    (iup:frame 
	     #:title "filter test and items"
	     (iup:hbox
	      (iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
			   #:action (lambda (obj unk val)
				      (mark-for-update)
				      (update-search "test-name" val)))
	      ;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
		    #:selection-cb
		    (lambda (obj id state)
		      ;; (print "obj: " obj ", id: " id ", state: " state)
		      (let* ((run-path (tree:node->path obj id))
			     (test-id  (tree-path->test-id (cdr run-path))))
			(if test-id
			    (hash-table-set! (dboard:data-get-curr-test-ids *data*)
					     window-id test-id))
			(print "path: " (tree:node->path obj id) " test-id: " test-id))))))
     (iup:attribute-set! tb "VALUE" "0")
	      ;;  	   #:action (lambda (obj unk val)
	      ;;  		      (mark-for-update)
	      ;;  		      (update-search "item-name" val))
	      ))
	    (iup:vbox
	     (iup:hbox
	      (let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus"))
		     (lb         (iup:listbox #:expand "HORIZONTAL"
					      #:dropdown "YES"
     (iup:attribute-set! tb "NAME" "Runs")
     ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
     (dboard:data-set-tests-tree! *data* tb)
     tb)
   (test-panel window-id)))

;; The function to update the fields in the test view panel
(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
  ;; get test-id
  ;; then get test record
					      #:action (lambda (obj val index lbstate)
							 (set! *tests-sort-reverse* index)
							 (mark-for-update))))
		     (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
		(iuplistbox-fill-list lb cmds-list selected-item: default-cmd)
  (if testdat
      (let* ((test-id      (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f))
	     (test-data    (hash-table-ref/default testdat test-id #f))
	     (run-id       (db:test-get-run_id test-data))
	     (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) 
		(mark-for-update)
		;; (set! *tests-sort-reverse* *tests-sort-reverse*0)
		lb)
	      ;; (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*))
						   run-id
						 (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 *dbstruct-local* (db:close-all *dbstruct-local*))
	     (target       (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
	     (runname      (if (null? targ/runname) "" (car (cdr targ/runname))))
	     (steps-dat    (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
						 (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)
				
	(if test-data
	    (begin
	      ;; 
	      (for-each 
								     (hash-table-set! *collapsed* tname #t))
								   *all-item-test-names*)
							 (iup:attribute-set! obj "TITLE" "Expand"))
						       (begin
							 (for-each (lambda (tname)
	       (lambda (data)
		 (let ((mat    (car data))
		       (vals   (cadr data))
		       (rownum 1))
		   (for-each 
								     (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)
		    (lambda (key)
		     (iup:toggle status  #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
		      (let ((cell   (conc rownum ":1")))
			(if (not (equal? (iup:attribute mat cell)(conc key)))
							  (hash-table-set! *status-ignore-hash* status #t)
							  (hash-table-delete! *status-ignore-hash* status))
						      (set-bg-on-filter))))
		   (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
	     (apply 
	      iup:hbox
			    (begin
			      ;; (print "setting cell " cell " in matrix " mat " to value " key)
			      (iup:attribute-set! mat cell (conc key))
	      (map (lambda (state)
		     (iup:toggle state   #:action   (lambda (obj val)
			      (iup:attribute-set! mat "REDRAW" cell)))
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *state-ignore-hash* state #t)
			(set! rownum (+ rownum 1))))
							  (hash-table-delete! *state-ignore-hash* state))
						      (set-bg-on-filter))))
		   (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
		    vals)))
	       (list 
	     (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)
		(list run-info-matrix
		      (if test-id
			  (list (db:test-get-run_id test-data)
				target
						 (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
				runname
				"n/a")
			   #: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))))
	   )
	  )
    
			  (make-list 4 "")))
    ;; create the left most column for the run key names and the test names 
    (set! lftlst (list (iup:hbox
		(list test-info-matrix
			(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)
		      (if test-id
										   (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"
			  (list test-id
				(db:test-get-testname test-data)
				(db:test-get-item-path test-data)
				(db:test-get-state    test-data)
				(db:test-get-status   test-data)
				(seconds->string (db:test-get-event_time test-data))
				(db:test-get-comment  test-data))
			  (make-list 7 "")))
		(list test-run-matrix
		      (if test-id
			  (list (db:test-get-host     test-data)
						     (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)
				(db:test-get-uname    test-data)
				(db:test-get-diskfree test-data)
				(db:test-get-cpuload  test-data)
				(seconds->hr-min-sec (db:test-get-run_duration test-data)))
			  (make-list 5 "")))
											     (iup:attribute-set! obj "MAX" newmax))
											 ))
		))
								   #:expand "VERTICAL" 
								   #:orientation "VERTICAL"
								   #:min 0
								   #:step 0.01)
						     (apply iup:vbox (reverse res)))))))
	      (dcommon:populate-steps steps-dat steps-matrix))))))
       (else
	(let ((labl  (iup:button "" 
				 #:flat "YES" 
		;;(list meta-dat-matrix
				 #:alignment "ALEFT"
					; #:image img1
		;;      (if test-id
					; #:impress img2
				 #:size "x15"
				 #:expand "HORIZONTAL"
				 #:fontsize "10"
				 #:action (lambda (obj)
		;;	  (list (
					    (mark-for-update)
					    (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE"))))
	  (vector-set! lftcol testnum labl)
	  (loop (+ testnum 1)(cons labl res))))))
    ;; 
    (let loop ((runnum  0)
	       (keynum  0)
	       (keyvec  (make-vector nkeys))
	       (res    '()))
      (cond ;; nb// no else for this approach.
       ((>= runnum nruns) #f)

  
;; db:test-get-id           
;; db:test-get-run_id       
;; db:test-get-testname     
;; db:test-get-state        
;; db:test-get-status       
;; db:test-get-event_time   
       ((>= keynum nkeys) 
	(vector-set! header runnum keyvec)
	(set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst))
	(loop (+ runnum 1) 0 (make-vector nkeys) '()))
       (else
	(let ((labl  (iup:label "" #:size "60x15" #:fontsize "10" #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL"
	  (vector-set! keyvec keynum labl)
	  (loop runnum (+ keynum 1) keyvec (cons labl res))))))
    ;; By here the hdrlst contains a list of vboxes containing nkeys labels
    (let loop ((runnum  0)
	       (testnum 0)
	       (testvec  (make-vector ntests))
	       (res    '()))
      (cond
;; db:test-get-host         
;; db:test-get-cpuload      
;; db:test-get-diskfree     
;; db:test-get-uname        
;; db:test-get-rundir       
       ((>= runnum nruns) #f) ;;  (vector tableheader runsvec))
       ((>= testnum ntests) 
	(vector-set! runsvec runnum testvec)
;; db:test-get-item-path    
;; db:test-get-run_duration 
	(set! bdylst (cons (apply iup:vbox (reverse res)) bdylst))
	(loop (+ runnum 1) 0 (make-vector ntests) '()))
;; db:test-get-final_logf   
       (else
	(let* ((button-key (mkstr runnum testnum))
	       (butn       (iup:button "" ;; button-key 
;; db:test-get-comment      
;; db:test-get-fullname     	  
				       #:size "60x15" 
				       #: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)))
							 (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
							 (cmd  (conc toolpath " -test " run-id "," test-id "&")))
;;======================================================================
;; R U N   C O N T R O L
;;======================================================================

					;(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))))))
;; Overall runs browser
    ;; now assemble the hdrlst and bdylst and kick off the dialog
    (iup:show
;;
(define (runs window-id)
     (iup:dialog 
      #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
      #:menu (dcommon:main-menu)
      (let* ((runs-view (iup:vbox
  (let* ((runs-matrix     (iup:matrix
			 (apply iup:hbox 
				(cons (apply iup:vbox lftlst)
				      (list 
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
				       (iup:vbox
					;; the header
					(apply iup:hbox (reverse hdrlst))
					(apply iup:hbox (reverse bdylst))))))
			 controls))
			   #:numcol-visible 7
	     (tabs (iup:tabs
		    #:tabchangepos-cb (lambda (obj curr prev)
					(set! *please-update-buttons* #t)
			   #:numlin-visible 7
			   #:click-cb (lambda (obj lin col status)
					(print "obj: " obj " lin: " lin " col: " col " status: " status)))))

					(set! *current-tab-number* curr))
		    (dashboard:summary db)
		    runs-view
    (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
		    (dashboard:one-run db)
		    (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! runs-matrix "WIDTH0" "100")
	(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))
    (dboard:data-set-runs-matrix! *data* runs-matrix)
    (iup:hbox
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

     (iup:frame 
;; 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 *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)

      #:title "Runs browser"
(define (dashboard:been-changed)
  (> (file-modification-time *db-file-path*) *last-db-update-time*))

      (iup:vbox
(define (dashboard:set-db-update-time)
  (set! *last-db-update-time* (file-modification-time *db-file-path*)))

       runs-matrix)))))
(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 *dbdir* "/monitor.db"))
(define *last-monitor-update-time* 0)

;; Browse and control a single run
;; Force creation of the db in case it isn't already there.
(tasks:open-db)

(define (dashboard:get-youngest-run-db-mod-time)
;;
(define (runcontrol window-id)
  (handle-exceptions
   exn
  (iup:hbox))
   (begin
     (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
     (current-seconds)) ;; something went wrong - just print an error and return current-seconds
   (apply max (map (lambda (filen)
		     (file-modification-time filen))
		   (glob (conc *dbdir* "/*.db"))))))

(define (dashboard:run-update x)
  (let* ((modtime         (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*))
	 (monitor-modtime (if (file-exists? *monitor-db-path*)
			      (file-modification-time *monitor-db-path*)
			      -1))
	 (run-update-time (current-seconds))
	 (recalc          (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
    (if (and (eq? *current-tab-number* 0)
	     (or (> monitor-modtime *last-monitor-update-time*)
		 (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
	(begin
	  (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
	  (if dashboard:update-servers-table (dashboard:update-servers-table))))
;;======================================================================
;; D A S H B O A R D
;;======================================================================

    (if recalc
	(begin	
;; Main Panel
	  (case *current-tab-number* 
	    ((0) 
	     (if dashboard:update-summary-tab (dashboard:update-summary-tab)))
	    ((1) ;; The runs table is active
(define (main-panel window-id)
  (iup:dialog
   #:title "Megatest Control Panel"
   #:menu (dcommon:main-menu)
   #:shrink "YES"
	     (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 '()))
   (let ((tabtop (iup:tabs 
			      (for-each (lambda (key)
					  (if (not (equal? key "runname"))
		  (runs window-id)
					      (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)
		  (tests window-id)
		  (runcontrol window-id)
		  (mtest window-id) 
		  (rconfig window-id)
		  )))
	     (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)
     (iup:attribute-set! tabtop "TABTITLE0" "Runs")
     (iup:attribute-set! tabtop "TABTITLE1" "Tests")
     (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
	  (set! *last-recalc-ended-time* (current-milliseconds))))))

     (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") 
;;======================================================================
;; The heavy lifting starts here
     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))
;;======================================================================

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

(cond 
 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
(define (newdashboard data)
	  (lambda (x)
	    (on-exit std-exit-procedure)
	    (examine-run *dbstruct-local* runid)))
  (let* ((keys     (db:get-keys dbstruct))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test") ;; run-id,test-id
  (let* ((dat     (map string->number (string-split (args:get-arg "-test") ",")))
	 (run-id  (car dat))
	 (test-id (cadr dat)))
	 (runname  "%")
	 (testpatt "%")
    (if (and (number? run-id)
	     (number? test-id)
	     (>= test-id 0))
	 (keypatts (map (lambda (k)(list k "%")) keys))
	 (states   '())
	(examine-test run-id test-id)
	(begin
	  (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor *dbstruct-local*))
 (else
	 (statuses '())
  (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*))
  (iup:callback-set! *tim*
	 (nextmintime (current-milliseconds))
	 (my-window-id *current-window-id*))
    (set! *current-window-id* (+ 1 *current-window-id*))
    (dboard:data-set-runs! *data* data) ;; make this data available to the rest of the application
    (iup:show (main-panel my-window-id))
		     "ACTION_CB"
		     (lambda (x)
		       (let ((update-is-running #f))
    ;; Yes, running iup:show will pop up a new panel
			 (mutex-lock! *update-mutex*)
    ;; (iup:show (main-panel my-window-id))
			 (set! update-is-running *update-is-running*)
			 (if (not update-is-running)
			     (set! *update-is-running* #t))
    (iup:callback-set! *tim*
			 (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))))

(let ((th1 (make-thread (lambda ()
		       "ACTION_CB"
		       (lambda (x)
			  (thread-sleep! 1)
			  (set! *please-update-buttons* #t)
			  (dashboard:run-update 1)) "update buttons once"))
			  ;; need to wait for first *update-is-running* #t
			  ;; (let loop ()
			 ;; Want to dedicate no more than 50% of the time to this so skip if
			 ;; 2x delta time has not passed since last query
			  ;;   (mutex-lock! *update-mutex*)
			  ;;   (if *update-is-running*
			  ;;       (begin
			  ;;         (set! *please-update-buttons* #t)
			 (if (< nextmintime (current-milliseconds))
			     (let* ((starttime (current-milliseconds))
				    (changes   (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
				    (endtime   (current-milliseconds)))
			       (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
			  ;;         (mark-for-update)
			  ;;         (print "Did redraw trigger")) "First update after startup")
			       (debug:print 11 "CHANGE(S): " (car changes) "..."))
			  ;;   (mutex-unlock! *update-mutex*)
			  ;;   (thread-sleep! 1)
			     (debug:print-info 11 "Server overloaded"))))))
;;; main
			  ;;   (if (not *please-update-buttons*)
			  ;;       (loop))))))
      (th2 (make-thread iup:main-loop "Main loop")))
;;;
(let ((data (make-hash-table))) ;; data will have "areaname" => "area record" entries
  (thread-start! th1)
  (thread-start! th2)
  (thread-join! th2))

;; (iup:main-loop)(db:close-all *dbstruct-local*)
  (newdashboard data)
  (iup:main-loop))

;; Get/open a database
;;    if run-id => get run specific db
;;    if #f     => get main db
;;    if db already open - return inmem
;;    if db not open, open inmem, rundb and sync then return inmem
;;    inuse gets set automatically for rundb's
;;
(define (db:get-db dbstruct run-id)
(define (db:get-db dbstruct area-dat run-id)
  (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through
      dbstruct
      (begin
	(mutex-lock! *rundb-mutex*)
	(let ((dbdat (if (or (not run-id)
			     (eq? run-id 0))
			 (db:open-main dbstruct)
			 (db:open-rundb dbstruct run-id)
			 (db:open-main dbstruct area-dat)
			 (db:open-rundb dbstruct area-dat run-id)
			 )))
	  ;; db prunning would go here
	  (mutex-unlock! *rundb-mutex*)
	  dbdat))))

(define (db:dbdat-get-db dbdat)
  (if (pair? dbdat)

	    (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds)))
	(dbr:dbstruct-set-inuse! dbstruct #f)
	(mutex-unlock! *rundb-mutex*))))

;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
(define (db:with-db dbstruct area-dat run-id r/w proc . params)
  (let* ((dbdat (if (vector? dbstruct)
		    (db:get-db dbstruct run-id)
		    (db:get-db dbstruct area-dat run-id)
		    dbstruct)) ;; cheat, allow for passing in a dbdat
	 (db    (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
       (print-call-chain (current-error-port)))
     (let ((res (apply proc db params)))
       (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
       res))))

;;======================================================================
;; K E E P   F I L E D B   I N   dbstruct
;;======================================================================

;; (define (db:get-filedb dbstruct run-id)
;;   (let ((db (vector-ref dbstruct 2)))
;;     (if db
;; 	db
;; 	(let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
;; 	(let ((fdb (filedb:open-db (conc toppath "/db/files.db"))))
;; 	  (vector-set! dbstruct 2 fdb)
;; 	  fdb))))
;; 
;; ;; Can also be used to save arbitrary strings
;; ;;
;; (define (db:save-path dbstruct path)
;;   (let ((fdb (db:get-filedb dbstruct)))b
;;     (filedb:register-path fdb path)))
;; 
;; ;; Use to get a path. To get an arbitrary string see next define
;; ;;
;; (define (db:get-path dbstruct id)
;;   (let ((fdb (db:get-filedb dbstruct)))
;;     (filedb:get-path db id)))

;; NB// #f => return dbdir only
;;      (was planned to be;  zeroth db with name=main.db)
;;
(define (db:dbfile-path run-id)
(define (db:dbfile-path run-id area-dat)
  (let* (;; (toppath      (dbr:dbstruct-get-path  dbstruct))
	 (configdat       (megatest:area-configdat area-dat))
	 (toppath         (megatest:area-path      area-dat))
	 (link-tree-path  (configf:lookup *configdat* "setup" "linktree"))
	 (dbpath          (configf:lookup *configdat* "setup" "dbdir"))
	 (link-tree-path  (configf:lookup configdat "setup" "linktree"))
	 (dbpath          (configf:lookup configdat "setup" "dbdir"))
	 (fname           (if run-id
			      (if (eq? run-id 0) "main.db" (conc run-id ".db"))
			      #f))
	 (dbdir           (if dbpath
			      dbpath
			      (conc link-tree-path "/.db/"))))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "ERROR: Couldn't create path to " dbdir)
       (exit 1))
     (if (not (directory? dbdir))(create-directory dbdir #t)))
    (if fname
	(conc dbdir fname)
	dbdir)))
	       
(define (db:set-sync db)
  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
(define (db:set-sync db area-dat)
  (let ((syncprag (configf:lookup (megatest:area-configdat area-dat) "setup" "sychronous")))
    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";"))))

;; open an sql database inside a file lock
;;
;; returns: db existed-prior-to-opening
;;
(define (db:lock-create-open fname initproc)
(define (db:lock-create-open fname initproc area-dat)
  (if (file-exists? fname)
      (let ((db (sqlite3:open-database fname)))
	(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	(db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	(db:set-sync db area-dat) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	db)
      (let* ((parent-dir   (pathname-directory fname))
	     (dir-writable (file-write-access? parent-dir)))
	(if dir-writable
	    (let ((exists  (file-exists? fname))
		  (lock    (obtain-dot-lock fname 1 5 10))
		  (db      (sqlite3:open-database fname)))
	      (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	      (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	      (db:set-sync db area-dat) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	      (if (not exists)(initproc db))
	      (release-dot-lock fname)
	      db)
	    (begin
	      (debug:print 0 "ERROR: no such db in non-writable dir " fname)
	      (sqlite3:open-database fname))))))

;; This routine creates the db. It is only called if the db is not already opened
;; 
(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
(define (db:open-rundb dbstruct area-dat run-id #!key (attemptnum 0)(do-not-open #f)) ;;  (conc toppath "/megatest.db") (car configinfo)))
  (let* ((local  (dbr:dbstruct-get-local dbstruct))
	 (rdb    (if local
		     (dbr:dbstruct-get-localdb dbstruct run-id)
		     (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
    (if (or rdb
	    do-not-open)
	rdb
	(let* ((dbpath       (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
	(let* ((dbpath       (db:dbfile-path run-id area-dat)) ;; (conc toppath "/db/" run-id ".db"))
	       (dbexists     (file-exists? dbpath))
	       (inmem        (if local #f (db:open-inmem-db)))
	       (refdb        (if local #f (db:open-inmem-db)))
	       (db           (db:lock-create-open dbpath ;; this is the database physically on disk
						  (lambda (db)
						    (handle-exceptions
						     exn
						     (begin
						       (release-dot-lock dbpath)
						       (if (> attemptnum 2)
							   (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath)
							   (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1))))
							   (db:open-rundb dbstruct area-dat run-id attemptnum (+ attemptnum 1))))
						     (db:initialize-run-id-db db)
						     (sqlite3:execute 
						      db
						      "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');"
						      (* run-id 30000) ;; allow for up to 30k tests per run
						      run-id)
						     ;; do a dummy query to test that the table exists and the db is truly readable
						     (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000))
						    ))
						    )))) ;; add strings db to rundb, not in use yet
						  area-dat)) ;; add strings db to rundb, not in use yet
	       ;;   )) ;; (sqlite3:open-database dbpath))
	       (olddb        (if *megatest-db*
				 *megatest-db* 
				 (let ((db (db:open-megatest-db)))
				 (let ((db (db:open-megatest-db area-dat)))
				   (set! *megatest-db* db)
				   db)))
	       (write-access (file-write-access? dbpath))
	       ;; (handler      (make-busy-timeout 136000))
	       )
	  (if (and dbexists (not write-access))
	      (set! *db-write-access* #f)) ;; only unset so other db's also can use this control
	  (dbr:dbstruct-set-rundb!  dbstruct (cons db dbpath))
	  (dbr:dbstruct-set-inuse!  dbstruct #t)
	  (dbr:dbstruct-set-olddb!  dbstruct olddb)
	  ;; (dbr:dbstruct-set-run-id! dbstruct run-id)
	  (if local
	      (begin
		(dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ...
		db)
	      (begin
		(dbr:dbstruct-set-inmem!  dbstruct inmem)
		;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders
		;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context
		(db:sync-tables db:sync-tests-only db inmem)
		(db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? 
		(db:sync-tables area-dat db:sync-tests-only db inmem)
		(db:delay-if-busy refdb area-dat) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? 
		(dbr:dbstruct-set-refdb!  dbstruct refdb)
		(db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
		(db:sync-tables area-dat db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
		;; sync once more to deal with delays?
		;; (db:sync-tables db:sync-tests-only db inmem)
		;; (db:sync-tables db:sync-tests-only inmem refdb)
		inmem))))))

;; This routine creates the db. It is only called if the db is not already ls opened
;;
(define (db:open-main dbstruct) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
(define (db:open-main dbstruct area-dat) ;;  (conc toppath "/megatest.db") (car configinfo)))
  (let ((mdb (dbr:dbstruct-get-main dbstruct)))
    (if mdb
	mdb
	(let* ((dbpath       (db:dbfile-path 0))
	(let* ((dbpath       (db:dbfile-path 0 area-dat))
	       (dbexists     (file-exists? dbpath))
	       (db           (db:lock-create-open dbpath db:initialize-main-db))
	       (olddb        (db:open-megatest-db))
	       (db           (db:lock-create-open dbpath 
						  (lambda (db)
						    (db:initialize-main-db db area-dat))
						  area-dat))
	       (olddb        (db:open-megatest-db area-dat))
	       (write-access (file-write-access? dbpath))
	       (dbdat        (cons db dbpath)))
	  (if (and dbexists (not write-access))
	      (set! *db-write-access* #f))
	  (dbr:dbstruct-set-main!   dbstruct dbdat)
	  (dbr:dbstruct-set-olddb!  dbstruct olddb) ;; olddb is already a (cons db path)
	  dbdat))))

;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
(define (db:setup run-id #!key (local #f))
  (let* ((dbdir    (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define (db:setup run-id area-dat #!key (local #f))
  (let* ((dbdir    (db:dbfile-path #f area-dat)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db"))
	 (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
    dbstruct))

;; Open the classic megatest.db file in toppath
;;
(define (db:open-megatest-db)
  (let* ((dbpath       (conc *toppath* "/megatest.db"))
(define (db:open-megatest-db area-dat)
  (let* ((toppath      (megatest:area-path area-dat))
	 (dbpath       (conc toppath "/megatest.db"))
	 (dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
					      (db:initialize-main-db db)
					      (db:initialize-run-id-db db))))
					      (db:initialize-main-db db area-dat)
					      (db:initialize-run-id-db db))
					    area-dat))
	 (write-access (file-write-access? dbpath)))
    (if (and dbexists (not write-access))
	(set! *db-write-access* #f))
    (cons db dbpath)))

;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
(define (db:sync-touched dbstruct area-dat run-id #!key (force-sync #f))
  (let ((mtime  (dbr:dbstruct-get-mtime dbstruct))
	(stime  (dbr:dbstruct-get-stime dbstruct))
	(rundb  (dbr:dbstruct-get-rundb dbstruct))
	(inmem  (dbr:dbstruct-get-inmem dbstruct))
	(maindb (dbr:dbstruct-get-main  dbstruct))
	(refdb  (dbr:dbstruct-get-refdb dbstruct))
	(olddb  (dbr:dbstruct-get-olddb dbstruct))
	;; (runid  (dbr:dbstruct-get-run-id dbstruct))
	)
    (debug:print-info 4 "Syncing for run-id: " run-id)
    ;; (mutex-lock! *http-mutex*)
    (if (eq? run-id 0)
	;; runid equal to 0 is main.db
	(if maindb
	    (if (or (not (number? mtime))
		    (not (number? stime))
		    (> mtime stime)
		    force-sync)
		(begin
		  (db:delay-if-busy maindb)
		  (db:delay-if-busy olddb)
		  (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb)))
		  (db:delay-if-busy maindb area-dat)
		  (db:delay-if-busy olddb area-dat)
		  (let ((num-synced (db:sync-tables area-dat (db:sync-main-list maindb area-dat) maindb olddb)))
		    (dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
		    num-synced)
		  0))
	    (begin
	      ;; this can occur when using local access (i.e. not in a server)
	      ;; need a flag to turn it off.
	      ;;
	      (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized")
	      0))
	;; any other runid is a run
	(if (or (not (number? mtime))
		(not (number? stime))
		(> mtime stime)
		force-sync)
	    (begin
	      (db:delay-if-busy rundb)
	      (db:delay-if-busy olddb)
	      (db:delay-if-busy rundb area-dat)
	      (db:delay-if-busy olddb area-dat)
	      (dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
	      (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb)))
	      (let ((num-synced (db:sync-tables area-dat db:sync-tests-only inmem refdb rundb olddb)))
		;; (mutex-unlock! *http-mutex*)
		num-synced)
	      (begin
		;; (mutex-unlock! *http-mutex*)
		0))))))

(define (db:close-main dbstruct)
(define (db:close-main dbstruct area-dat)
  (let ((maindb (dbr:dbstruct-get-main dbstruct)))
    (if maindb
	(begin
	  (sqlite3:finalize! (db:dbdat-get-db maindb))
	  (dbr:dbstruct-set-main! dbstruct #f)))))

(define (db:close-run-db dbstruct run-id)
(define (db:close-run-db dbstruct area-dat run-id)
  (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t)))
    (if (and rdb
	     (sqlite3:database? rdb))
	(begin
	  (sqlite3:finalize! rdb)
	  (dbr:dbstruct-set-localdb! dbstruct run-id #f)
	  (dbr:dbstruct-set-inmem! dbstruct #f)))))

;; close all opened run-id dbs
(define (db:close-all dbstruct)
(define (db:close-all dbstruct area-dat)
  ;; finalize main.db
  (db:sync-touched dbstruct 0 force-sync: #t)
  (db:sync-touched dbstruct area-dat 0 force-sync: #t)
  ;;(common:db-block-further-queries)
  ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism?

  (db:close-main dbstruct)
  (db:close-main dbstruct area-dat)
  
  (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct)))
    (if (hash-table? locdbs)
	(for-each (lambda (run-id)
		    (db:close-run-db dbstruct run-id))
		    (db:close-run-db dbstruct area-dat run-id))
		  (hash-table-keys locdbs))))

  ;; (let* ((local (dbr:dbstruct-get-local dbstruct))
  ;;        (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))
  ;;   (if local
  ;;       (for-each
  ;;        (lambda (dbdat)

	 '("units"          #f)
	 '("comment"        #f)
	 '("status"         #f)
	 '("type"           #f))))

;; needs db to get keys, this is for syncing all tables
;;
(define (db:sync-main-list db)
  (let ((keys  (db:get-keys db)))
(define (db:sync-main-list db area-dat)
  (let ((keys  (db:get-keys db area-dat)))
    (list
     (list "keys"
	   '("id"        #f)
	   '("fieldname" #f)
	   '("fieldtype" #f))
     (list "metadat" '("var" #f) '("val" #f))
     (append (list "runs" 

	   '("avg_disk"       #f)
	   '("tags"           #f)
	   '("jobgroup"       #f)))))
    
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are dbdat's
;;
(define (db:sync-tables tbls fromdb todb . slave-dbs)
(define (db:sync-tables area-dat tbls fromdb todb . slave-dbs)
  (mutex-lock! *db-sync-mutex*)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
     (print-call-chain (current-error-port))
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))

		 (full-sel   (conc "SELECT " (string-intersperse (map car fields) ",") 
				   " FROM " tablename ";"))
		 (full-ins   (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
				   " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
		 (fromdat    '())
		 (fromdats   '())
		 (totrecords 0)
		 (batch-len  (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10")))
		 (batch-len  (string->number (or (configf:lookup (megatest:area-configdat area-dat) "sync" "batchsize") "10")))
		 (todat      (make-hash-table))
		 (count      0))

	    ;; set up the field->num table
	    (for-each
	     (lambda (field)
	       (hash-table-set! field->num field count)

;;  'adj-testids  - move test-ids into correct ranges
;;  'old2new      - sync megatest.db records to .db/{main,1,2 ...}.db
;;  'new2old      - sync .db/{main,1,2,3 ...}.db to megatest.db
;;  'closeall     - close all opened dbs
;;
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync run-ids . options)
  (let* ((toppath  (launch:setup-for-run))
(define (db:multi-db-sync run-ids area-dat . options)
  (let* ((toppath  (launch:setup-for-run area-dat))
	 (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	 (mtdb     (if toppath (db:open-megatest-db)))
	 (mtdb     (if toppath (db:open-megatest-db area-dat)))
	 (allow-cleanup (if run-ids #f #t))
	 (run-ids  (if run-ids 
		       run-ids
		       (if toppath (begin
				     (db:delay-if-busy mtdb)
				     (db:get-all-run-ids mtdb)))))
	 (tdbdat  (tasks:open-db))
	 (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))))
				     (db:delay-if-busy mtdb area-dat)
				     (db:get-all-run-ids mtdb area-dat)))))
	 (tdbdat  (tasks:open-db area-dat))
	 (servers (tasks:get-all-servers (db:delay-if-busy tdbdat area-dat))))
    
    ;; kill servers
    (if (member 'killservers options)
	(for-each
	 (lambda (server)
	   (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration")
	   (tasks:server-delete-record (db:delay-if-busy tdbdat area-dat) (vector-ref server 0) "dbmigration")
	   (tasks:kill-server (vector-ref server 2)(vector-ref server 1)))
	 servers))

    ;; clear out junk records
    ;;
    (if (member 'dejunk options)
	(begin
	  (db:delay-if-busy mtdb)
	  (db:delay-if-busy mtdb area-dat)
	  (db:clean-up mtdb)))

    ;; adjust test-ids to fit into proper range
    ;;
    (if (member 'adj-testids options)
	(begin
	  (db:delay-if-busy mtdb)
	  (db:prep-megatest.db-for-migration mtdb)))
	  (db:delay-if-busy mtdb area-dat)
	  (db:prep-megatest.db-for-migration mtdb area-dat)))

    ;; sync runs, test_meta etc.
    ;;
    (if (member 'old2new options)
	(begin
	  (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f))
	  (db:sync-tables area-dat (db:sync-main-list mtdb area-dat) mtdb (db:get-db dbstruct area-dat #f))
	  (for-each 
	   (lambda (run-id)
	     (db:delay-if-busy mtdb)
	     (db:delay-if-busy mtdb area-dat)
	     (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))
		   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
	       (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
	       (db:replace-test-records dbstruct run-id testrecs)
	       (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))))
	   run-ids)))

    ;; now ensure all newdb data are synced to megatest.db
    ;; do not use the run-ids list passed in to the function
    ;;
    (if (member 'new2old options)
	(let* ((maindb      (make-dbr:dbstruct path: toppath local: #t))
	       (src-run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0))))
	       (src-run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb area-dat 0)) area-dat))
	       (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <))
	       (count       1)
	       (total       (length all-run-ids))
	       (dead-runs  '()))
	  (for-each
	   (lambda (run-id)
	     (debug:print 0 "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total)
	     (set! count (+ count 1))
	     (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
		    (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
		    (frundb (db:dbdat-get-db (db:get-db fromdb area-dat run-id))))
	       ;; (db:delay-if-busy frundb)
	       ;; (db:delay-if-busy mtdb)
	       ;; (db:clean-up frundb)
	       (if (eq? run-id 0)
		   (begin
		     (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb)
		     (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))))
		     (db:sync-tables area-dat (db:sync-main-list dbstruct area-dat) (db:get-db fromdb area-dat #f) mtdb)
		     (set! dead-runs (db:clean-up-maindb (db:get-db fromdb area-dat #f) area-dat)))
		   (begin
		     ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db
		     (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)
		     (db:clean-up-rundb (db:get-db fromdb run-id))
		     (db:sync-tables area-dat db:sync-tests-only (db:get-db fromdb area-dat run-id) mtdb)
		     (db:clean-up-rundb (db:get-db fromdb area-dat run-id) area-dat)
		     ))))
	   all-run-ids)
	  ;; removed deleted runs
	  (let ((dbdir (tasks:get-task-db-path)))
	  (let ((dbdir (tasks:get-task-db-path area-dat)))
	    (for-each (lambda (run-id)
			(let ((fullname (conc dbdir "/" run-id ".db")))
			  (if (file-exists? fullname)
			      (begin
				(debug:print 0 "Removing database file for deleted run " fullname)
				(delete-file fullname)))))
		      dead-runs))))

;; (define open-run-close 
(define open-run-close open-run-close-exception-handling)
		;;	   open-run-close-no-exception-handling
;;			   open-run-close-exception-handling)
;;)

(define (db:initialize-main-db dbdat)
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
(define (db:initialize-main-db dbdat area-dat)
  (let* ((configdat (megatest:area-configdat area-dat)) ;; (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))
	 (db       (db:dbdat-get-db dbdat)))
    (for-each (lambda (key)
		(let ((keyn key))

;; A R C H I V E S
;;======================================================================

;; dneeded is minimum space needed, scan for existing archives that 
;; are on disks with adequate space and already have this test/itempath
;; archived
;;
(define (db:archive-get-allocations dbstruct testname itempath dneeded)
  (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
(define (db:archive-get-allocations dbstruct area-dat testname itempath dneeded)
  (let* ((dbdat        (db:get-db dbstruct area-dat #f)) ;; archive tables are in main.db
	 (db           (db:dbdat-get-db dbdat))
	 (res          '())
	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
    (sqlite3:for-each-row
     (lambda (id archive-disk-id disk-path last-du last-du-time)
       (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
     db

         last_df > ?;")
	 dneeded))
    blocks))
    
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
  (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
(define (db:archive-register-disk dbstruct area-dat bdisk-name bdisk-path df)
  (let* ((dbdat        (db:get-db dbstruct area-dat #f)) ;; archive tables are in main.db
	 (db           (db:dbdat-get-db dbdat))
	 (res          #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
     bdisk-name bdisk-path)
    (if res ;; record exists, update df and return id
	(begin
	  (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
                                  WHERE archive_area_name=? AND disk_path=?;"
			   df bdisk-name bdisk-path)
	  res)
	(begin
	  (sqlite3:execute
	   db
	   "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
                VALUES (?,?,?);"
	   bdisk-name bdisk-path df)
	  (db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))
	  (db:archive-register-disk dbstruct area-dat bdisk-name bdisk-path df)))))

;; record an archive path created on a given archive disk (identified by it's bdisk-id)
;; if path starts with / then it is full, otherwise it is relative to the archive disk
;; preference is to store the relative path.
;;
(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
  (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
(define (db:archive-register-block-name dbstruct area-dat bdisk-id archive-path #!key (du #f))
  (let* ((dbdat        (db:get-db dbstruct area-dat #f)) ;; archive tables are in main.db
	 (db           (db:dbdat-get-db dbdat))
	 (res          #f))
    ;; first look to see if this path is already registered
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
     bdisk-id archive-path)
    (if res ;; record exists, update du if applicable and return res
	(begin
	  (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
                                          WHERE archive_disk_id=? AND disk_path=?;"
				   bdisk-id archive-path du))
	  res)
	(begin
	  (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
                                                        VALUES (?,?,?);"
			   bdisk-id archive-path (or du 0))
	  (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))))
	  (db:archive-register-block-name dbstruct area-dat bdisk-id archive-path du: du)))))


;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
;;
(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
(define (db:test-set-archive-block-id dbstruct area-dat run-id area-dat test-id archive-block-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   area-dat
   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
		      archive-block-id test-id))))
 
;; Look up the archive block info given a block-id
;;
(define (db:test-get-archive-block-info dbstruct archive-block-id)
(define (db:test-get-archive-block-info dbstruct area-dat archive-block-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   #f
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row 
	;;        0         1           2        3          4           5
	(lambda (id archive-disk-id disk-path last-du last-du-time creation-time)

;; 	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
;;     (sqlite3:for-each-row  #f)

;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((dbpath    (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
(define (open-logging-db area-dat) ;;  (conc toppath "/megatest.db") (car configinfo)))
  (let* ((toppath   (megatest:area-path area-dat))
	 (dbpath    (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath))
	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					   (string->number (args:get-arg "-override-timeout"))
					   136000)))) ;; 136000)))
    (sqlite3:set-busy-handler! db handler)
    (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);")
	  (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
	  (db:set-sync db area-dat) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
	  ))
    db))

(define (db:log-local-event . loglst)
  (let ((logline (apply conc loglst)))
    (db:log-event logline)))

;; D B   U T I L S
;;======================================================================

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

(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
  (let* ((dbdat        (db:get-db dbstruct run-id))
(define (db:have-incompletes? dbstruct area-dat run-id ovr-deadtime)
  (let* ((dbdat        (db:get-db dbstruct area-dat run-id))
	 (db           (db:dbdat-get-db dbdat))
	 (incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime-str (configf:lookup (megatest:area-configdat area-dat) "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200))) ;; two hours
    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
    
    ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
    ;;
    ;; 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) 
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat) 
    (sqlite3:for-each-row 
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (begin
	     (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	     (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
	   (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
     db
     "SELECT id,rundir,uname,testname,item_path 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
    ;;
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	   (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))

	#t)))

;;  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 dbstruct run-id ovr-deadtime)
  (let* ((dbdat        (db:get-db dbstruct run-id))
(define (db:find-and-mark-incomplete dbstruct area-dat run-id ovr-deadtime area-dat)
  (let* ((dbdat        (db:get-db dbstruct area-dat run-id))
	 (db           (db:dbdat-get-db dbdat))
	 (incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime-str (configf:lookup (megatest:area-configdat area-dat) "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200))) ;; two hours
    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
    
    ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
    ;;
    ;; 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) 
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row 
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (begin
	     (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	     (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
	   (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
     db
     "SELECT id,rundir,uname,testname,item_path 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
    ;;
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	   (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
     db
     "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
     run-id)
    
    (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")

    ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
    ;;
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (let* (;; (min-incompleted (filter (lambda (x)
	   ;;      		      (let* ((testpath (cadr x))
	   ;;      			     (tdatpath (conc testpath "/testdat.db"))
	   ;;      			     (dbexists (file-exists? tdatpath)))
	   ;;      			(or (not dbexists) ;; if no file then something wrong - mark as incomplete
	   ;;      			    (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
	   ;;      		    incompleted))
	   (min-incompleted-ids (map car incompleted)) ;; do 'em all
	   (all-ids             (append min-incompleted-ids (map car oldlaunched))))
      (if (> (length all-ids) 0)
	  (begin
	    (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
	    (sqlite3:execute 
	     db
	     (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" 
		   (string-intersperse (map conc all-ids) ",")
		   ");")))))

    ;; Now do rollups for the toplevel tests
    ;;
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (for-each
     (lambda (toptest)
       (let ((test-name (list-ref toptest 3)))
;;	     (run-id    (list-ref toptest 5)))
	  (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) ;; (list run-id test-name))))
     toplevels)))
		     

	       ;; 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);"
	       ))))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (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)
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:execute db "VACUUM;")))

;; 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-rundb dbdat)
(define (db:clean-up-rundb dbdat area-dat)
  ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
  (let* ((db         (db:dbdat-get-db dbdat))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
	(statements
	 (map (lambda (stmt)
		(sqlite3:prepare db stmt))
	      (list
	       ;; delete all tests that belong to runs that are 'deleted'
	       ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
	       ;; delete all tests that are 'DELETED'
	       "DELETE FROM tests WHERE state='DELETED';"
	       ))))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (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)
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:execute db "VACUUM;")))

;; 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-maindb dbdat)
(define (db:clean-up-maindb dbdat area-dat)
  ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
  (let* ((db         (db:dbdat-get-db dbdat))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);"))
	 (statements
	  (map (lambda (stmt)
		 (sqlite3:prepare db stmt))
	       (list
		;; delete all tests that belong to runs that are 'deleted'
		;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
		;; delete all tests that are 'DELETED'
		"DELETE FROM runs WHERE state='deleted';"
		)))
	 (dead-runs '()))
    (sqlite3:for-each-row
     (lambda (run-id)
       (set! dead-runs (cons run-id dead-runs)))
       db
       "SELECT id FROM runs WHERE state='deleted';")
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (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)
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:execute db "VACUUM;")
    dead-runs))

;;======================================================================
;; M E T A   G E T   A N D   S E T   V A R S
;;======================================================================

;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
;; Operates on megatestdb
;;
(define (db:get-var dbstruct var)
(define (db:get-var dbstruct area-dat var area-dat)
  (let* ((start-ms (current-milliseconds))
         (throttle (let ((t  (config-lookup *configdat* "setup" "throttle")))
         (throttle (let ((t  (config-lookup (megatest:area-configdat area-dat) "setup" "throttle")))
		     (if t (string->number t) t)))
	 (res      #f)
	 (dbdat    (db:get-db dbstruct #f))
	 (dbdat    (db:get-db dbstruct area-dat #f))
	 (db       (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     db
     "SELECT val FROM metadat WHERE var=?;" var)
    ;; convert to number if can
    (if (string? res)
	(let ((valnum (string->number res)))
	  (if valnum (set! res valnum))))
    ;; scale by 10, average with current value.
    (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
						 (if throttle throttle 0.01)))
			    2))
    (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
	(begin
	  (debug:print-info 4 "launch throttle factor=" *global-delta*)
	  (set! *last-global-delta-printed* *global-delta*)))
    res))

(define (db:set-var dbstruct var val)
  (let ((dbdat (db:get-db dbstruct #f))
(define (db:set-var dbstruct area-dat var val)
  (let ((dbdat (db:get-db dbstruct area-dat #f))
	(db    (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))

(define (db:del-var dbstruct var)
(define (db:del-var dbstruct area-dat var)
  ;; (db:delay-if-busy)
  (db:with-db dbstruct #f #t 
  (db:with-db dbstruct area-dat #f #t 
	      (lambda (db)
		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" 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*
;; why get the keys from the db? why not get from the configdat
;; using keys:config-get-fields?

(define (db:get-keys dbstruct)
(define (db:get-keys dbstruct area-dat)
  (if *db-keys* *db-keys* 
      (let ((res '()))
	(db:with-db dbstruct #f #f
		    (lambda (db)
		      (sqlite3:for-each-row 
		       (lambda (key)
			 (set! res (cons key res)))
		       db
		       "SELECT fieldname FROM keys ORDER BY id DESC;")))
  (let ((res '()))
    (db:with-db dbstruct area-dat #f #f
		(lambda (db)
		  (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)))
    res))

;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
  (if (null? header) #f
      (let loop ((hed (car header))
		 (tal (cdr header))
		 (n   0))
	(if (equal? hed field)
	    (vector-ref row n)
	    (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))

;; Accessors for the header/data structure
;; get rows and header from 
(define (db:get-header vec)(vector-ref vec 0))
(define (db:get-rows   vec)(vector-ref vec 1))

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

(define (db:get-run-name-from-id dbstruct run-id)
(define (db:get-run-name-from-id dbstruct area-dat run-id)
  (db:with-db 
   dbstruct
   dbstruct area-dat
   #f ;; this is for the main runs db
   #f ;; does not modify db
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row
	(lambda (runname)
	  (set! res runname))
	db
	"SELECT runname FROM runs WHERE id=?;"
	run-id)
       res))))

(define (db:get-run-key-val dbstruct run-id key)
(define (db:get-run-key-val dbstruct area-dat run-id key)
  (db:with-db
   dbstruct
   dbstruct area-dat
   #f
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row
	(lambda (val)
	  (set! res val))

				 patts))
			comparator)))


;; register a test run with the db, this accesses the main.db and does NOT
;; use server api
;;
(define (db:register-run dbstruct keyvals runname state status user)
  (let* ((dbdat     (db:get-db dbstruct #f))
(define (db:register-run dbstruct area-dat keyvals runname state status user)
  (let* ((dbdat     (db:get-db dbstruct area-dat #f))
	 (db        (db:dbdat-get-db dbdat))
	 (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))
	  (db:delay-if-busy dbdat)
	  (db:delay-if-busy dbdat area-dat)
	  (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)
	  (db:delay-if-busy dbdat)
	  (db:delay-if-busy dbdat area-dat)
	  (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)
	  (db:delay-if-busy dbdat)
	  (db:delay-if-busy dbdat area-dat)
	  (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 dbstruct runpatt count offset keypatts)
(define (db:get-runs dbstruct area-dat runpatt count offset keypatts)
  (let* ((res       '())
	 (keys       (db:get-keys dbstruct))
	 (keys       (db:get-keys dbstruct area-dat))
	 (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 (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)
    (db:with-db dbstruct #f #f
    (db:with-db dbstruct area-dat #f #f
		(lambda (db)		
		  (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)))

;; 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-rows runinfo))
;;  to extract info from the structure returned
;;
;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames
;;
(define (db:get-run-ids-matching dbstruct keynames target res)
(define (db:get-run-ids-matching dbstruct area-dat keynames target res)
;; (define (db:get-runs-by-patt dbstruct 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"))

			(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)
    (db:with-db dbstruct #f #f ;; reads db, does not write to it.
    (db:with-db dbstruct area-dat #f #f ;; reads db, does not write to it.
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (a . r)
		     (set! res (cons (list->vector (cons a r)) res)))
		   (db:get-db dbstruct #f)
		   (db:get-db dbstruct area-dat #f)
		   qry-str
		   runnamepatt)))
    (vector header res)))

;; Get all targets from the db
;;
(define (db:get-targets dbstruct)
(define (db:get-targets dbstruct area-dat)
  (let* ((res       '())
	 (keys       (db:get-keys dbstruct))
	 (keys       (db:get-keys dbstruct area-dat))
	 (header     keys) ;; (map key:get-fieldname keys))
	 (keystr     (keys->keystr keys))
	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
	 (seen       (make-hash-table)))
    (db:with-db
     dbstruct
     dbstruct area-dat
     #f
     #f
     (lambda (db)
       (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 dbstruct runpatt)
(define (db:get-num-runs dbstruct area-dat runpatt)
  (db:with-db
   dbstruct
   dbstruct area-dat
   #f
   #f
   (lambda (db)
     (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))))

(define (db:get-all-run-ids dbstruct)
(define (db:get-all-run-ids dbstruct area-dat)
  (db:with-db
   dbstruct
   dbstruct area-dat
   #f
   #f
   (lambda (db)
     (let ((run-ids '()))
       (sqlite3:for-each-row
	(lambda (run-id)
	  (set! run-ids (cons run-id run-ids)))
	db
	"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
    (reverse run-ids)))))

;; get some basic run stats
;;
;; ( (runname (( state  count ) ... ))
;;   (   ...  
(define (db:get-run-stats dbstruct)
  (let* ((dbdat        (db:get-db dbstruct #f))
(define (db:get-run-stats dbstruct area-dat)
  (let* ((dbdat        (db:get-db dbstruct area-dat #f))
	 (db           (db:dbdat-get-db dbdat))
	 (totals       (make-hash-table))
	 (curr         (make-hash-table))
	 (res          '())
	 (runs-info    '()))
    ;; First get all the runname/run-ids
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (run-id runname)
       (set! runs-info (cons (list run-id runname) runs-info)))
     db
     "SELECT id,runname FROM runs WHERE state != 'deleted';")
    ;; for each run get stats data
    (for-each
     (lambda (run-info)
       ;; get the net state/status counts for this run
       (let* ((run-id   (car  run-info))
	      (run-name (cadr run-info)))
	 (db:with-db
	  dbstruct
	  dbstruct area-dat
	  run-id
	  #f
	  (lambda (db)
	    (sqlite3:for-each-row
	     (lambda (state status count)
	       (let ((netstate (if (equal? state "COMPLETED") status state)))
		 (if (string? netstate)

;; 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-rows runinfo))
;;  to extract info from the structure returned
;;
(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name)
(define (db:get-runs-by-patt dbstruct area-dat 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)

			(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)
    (db:with-db dbstruct #f #f ;; reads db, does not write to it.
    (db:with-db dbstruct area-dat #f #f ;; reads db, does not write to it.
		(lambda (db)
		  (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-rows runinfo))
(define (db:get-run-info dbstruct run-id)
(define (db:get-run-info dbstruct area-dat run-id)
  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
  ;;    (hash-table-ref *run-info-cache* run-id)
  (let* ((dbdat     (db:get-db dbstruct #f))
  (let* ((dbdat     (db:get-db dbstruct area-dat #f))
	 (db        (db:dbdat-get-db dbdat))
	 (res       (vector #f #f #f #f))
	 (keys      (db:get-keys dbstruct))
	 (keys      (db:get-keys dbstruct area-dat))
	 (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)
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (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 dbstruct run-id comment)
(define (db:set-comment-for-run dbstruct area-dat run-id comment)
  (db:with-db
   dbstruct
   dbstruct area-dat
   #f
   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
		      run-id))))

;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run dbstruct run-id)
(define (db:delete-run dbstruct area-dat run-id)
  ;; First set any related tests to DELETED
  (let* ((rdbdat (db:get-db dbstruct run-id))
  (let* ((rdbdat (db:get-db dbstruct area-dat run-id))
	 (rdb    (db:dbdat-get-db rdbdat))
	 (dbdat  (db:get-db dbstruct #f))
	 (dbdat  (db:get-db dbstruct area-dat #f))
	 (db     (db:dbdat-get-db dbdat)))
    (db:delay-if-busy rdbdat)
    (db:delay-if-busy rdbdat area-dat)
    (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';")
    (sqlite3:execute rdb "DELETE FROM test_steps;")
    (sqlite3:execute rdb "DELETE FROM test_data;")
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))

(define (db:update-run-event_time dbstruct run-id)
(define (db:update-run-event_time dbstruct area-dat run-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   #f
   #t
   (lambda (db)
     (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))))

(define (db:lock/unlock-run dbstruct run-id lock unlock user)
(define (db:lock/unlock-run dbstruct area-dat run-id lock unlock user)
  (db:with-db
   dbstruct
   dbstruct area-dat
   #f
   #t
   (lambda (db)
     (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:set-run-status dbstruct run-id status msg)
  (let* ((dbdat (db:get-db dbstruct #f))
(define (db:set-run-status dbstruct area-dat run-id status msg)
  (let* ((dbdat (db:get-db dbstruct area-dat #f))
	 (db    (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (if msg
	(sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
	(sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))

(define (db:get-run-status dbstruct run-id)
(define (db:get-run-status dbstruct area-dat run-id)
  (let ((res "n/a"))
    (db:with-db
     dbstruct
     dbstruct area-dat
     #f
     #f
     (lambda (db)
       (sqlite3:for-each-row 
	(lambda (status)
	  (set! res status))
	db
	"SELECT status FROM runs WHERE id=?;" 
	run-id)
       res))))

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

;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
(define (db:get-key-val-pairs dbstruct run-id)
  (let* ((keys (db:get-keys dbstruct))
(define (db:get-key-val-pairs dbstruct area-dat run-id)
  (let* ((keys (db:get-keys dbstruct area-dat))
	 (res  '())
	 (dbdat  (db:get-db dbstruct #f))
	 (dbdat  (db:get-db dbstruct area-dat #f))
	 (db     (db:dbdat-get-db dbdat)))
    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
	 (db:delay-if-busy dbdat)
	 (db:delay-if-busy dbdat area-dat)
	 (sqlite3:for-each-row 
	  (lambda (key-val)
	    (set! res (cons (list key key-val) res)))
	  db qry run-id)))
     keys)
    (reverse res)))

;; get key vals for a given run-id
(define (db:get-key-vals dbstruct run-id)
  (let* ((keys (db:get-keys dbstruct))
(define (db:get-key-vals dbstruct area-dat run-id)
  (let* ((keys (db:get-keys dbstruct area-dat))
	 (res  '())
	 (dbdat  (db:get-db dbstruct #f))
	 (dbdat  (db:get-db dbstruct area-dat #f))
	 (db     (db:dbdat-get-db dbdat)))
    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
	 (db:delay-if-busy dbdat)
	 (db:delay-if-busy dbdat area-dat)
	 (sqlite3:for-each-row 
	  (lambda (key-val)
	    (set! res (cons key-val res)))
	  db qry run-id)))
     keys)
    (let ((final-res (reverse res)))
      (hash-table-set! *keyvals* run-id final-res)
      final-res)))

;; The target is keyval1/keyval2..., cached in *target* as it is used often
(define (db:get-target dbstruct run-id)
  (let* ((keyvals (db:get-key-vals dbstruct run-id))
(define (db:get-target dbstruct area-dat run-id)
  (let* ((keyvals (db:get-key-vals dbstruct area-dat run-id))
	 (thekey  (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
    thekey))

;; Get run-ids for runs with same target but different runnames and NOT run-id
;;
(define (db:get-prev-run-ids dbstruct run-id)
(define (db:get-prev-run-ids dbstruct area-dat run-id)
  (let* ((keyvals (rmt:get-key-val-pairs run-id))
	 (kvalues (map cadr keyvals))
	 (keys    (rmt:get-keys))
	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
    (let ((prev-run-ids '()))
      (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
      (db:with-db dbstruct area-dat #f #f ;; #f means work with the zeroth db - i.e. the runs db
       (lambda (db)
	 (apply sqlite3:for-each-row
		(lambda (id)
		  (set! prev-run-ids (cons id prev-run-ids)))
		db
		(conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id)))))
      prev-run-ids)))

;;======================================================================
;;  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 dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
(define (db:get-tests-for-run dbstruct area-dat run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
  (if (not (number? run-id))
      (begin ;; no need to treat this as an error by default
	(debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id)
	;; (print-call-chain (current-error-port))
	'())
      (let* ((qryvalstr       (case qryvals
				((shortlist) "id,run_id,testname,item_path,state,status")

							 " ")))
				    (if sort-order sort-order " ")
				    (if limit  (conc " LIMIT " limit)   " ")
				    (if offset (conc " OFFSET " offset) " ")
				    ";"
				    )))
	(debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry)
	(db:with-db dbstruct run-id #f
	(db:with-db dbstruct area-dat run-id #f
		    (lambda (db)
		      (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

	  (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 dbstruct run-id testpatt)
(define (db:get-tests-for-run-state-status dbstruct area-dat run-id testpatt)
  (let* ((res            '())
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " 
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
    (debug:print-info 8 "db:get-tests-for-run qry=" qry)
    (db:with-db dbstruct run-id #f
    (db:with-db dbstruct area-dat run-id #f
		(lambda (db)
		  (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 
		   qry
		   run-id)))
    res))

(define (db:get-testinfo-state-status dbstruct run-id test-id)
(define (db:get-testinfo-state-status dbstruct area-dat run-id test-id)
  (let ((res            #f))
    (db:with-db dbstruct run-id #f
    (db:with-db dbstruct area-dat run-id #f
		(lambda (db)
		  (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 dbstruct run-ids testpatt states statuses not-in)
(define (db:get-tests-for-runs-mindata dbstruct area-dat run-ids testpatt states statuses not-in)
  (debug:print 0 "ERROR: BROKN!")
  ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))
)

;; get a useful subset of the tests data (used in dashboard
;;
(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
  (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path"))
(define (db:get-tests-for-run-mindata dbstruct area-dat run-id testpatt states statuses not-in)
  (db:get-tests-for-run dbstruct area-dat run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path"))

;; do not use.
;;
(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
(define (db:get-tests-for-runs dbstruct area-dat run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
  ;; (db:delay-if-busy)
  (let ((res '()))
    (for-each 
     (lambda (run-id)
       (set! res (append 
		  res 
		  (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals))))
		  (db:get-tests-for-run dbstruct area-dat run-id testpatt states statuses #f #f not-in #f #f qryvals))))
     (if run-ids
	 run-ids
	 (db:get-all-run-ids dbstruct)))
	 (db:get-all-run-ids dbstruct area-dat)))
    res))

;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
;;

(define (db:delete-test-records dbstruct run-id test-id)
  (let* ((dbdat (db:get-db dbstruct run-id))
(define (db:delete-test-records dbstruct area-dat run-id test-id)
  (let* ((dbdat (db:get-db dbstruct area-dat run-id))
	 (db    (db:dbdat-get-db dbdat)))
    (db:general-call dbdat 'delete-test-step-records (list test-id))
    ;; (db:delay-if-busy)
    (db:general-call dbdat 'delete-test-data-records (list test-id))
    (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))

(define (db:delete-old-deleted-test-records dbstruct)
  (let ((run-ids  (db:get-all-run-ids dbstruct))
(define (db:delete-old-deleted-test-records dbstruct area-dat)
  (let ((run-ids  (db:get-all-run-ids dbstruct area-dat))
	(targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
    (for-each
     (lambda (run-id)
       (db:with-db
	dbstruct
	dbstruct area-dat
	run-id
	#t
	(lambda (db)
	  (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime))))
     run-ids)))

;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
;;
		;;  AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
		;;(debug:print 0 "QRY: " qry)
		;; (db:delay-if-busy)

(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
(define (db:set-tests-state-status dbstruct area-dat run-id testnames currstate currstatus newstate newstatus)
  (for-each (lambda (testname)
	      (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
			       (if currstate  (conc "state='" currstate "' AND ") "")
			       (if currstatus (conc "status='" currstatus "' AND ") "")
			       " run_id=? AND testname LIKE ?;")))
		(db:with-db
		 dbstruct
		 dbstruct area-dat
		 run-id
		 #t
		 (lambda (db)
		   (sqlite3:execute db qry newstate newstatus run-id testname)))))
	    testnames))

;; 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 dbstruct run-id test-id newstate newstatus newcomment)
(define (db:test-set-state-status-by-id dbstruct area-dat run-id test-id newstate newstatus newcomment)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #t
   (lambda (db)
     (cond
      ((and newstate newstatus newcomment)
       (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid 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 ;; (sdb:qry 'getid newcomment)
				       test-id))))
     (mt:process-triggers run-id test-id newstate newstatus))))

;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-running dbstruct run-id)
(define (db:get-count-tests-running dbstruct area-dat run-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result 
      db
      ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
      ;; AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted')
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');"
      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" 
      ))))

;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-actually-running dbstruct run-id)
(define (db:get-count-tests-actually-running dbstruct area-dat run-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
      ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART') AND run_id=?;" 
      run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")

;; NEW BEHAVIOR: Look only at single run with run-id
;; 
;; (define (db:get-running-stats dbstruct run-id)
(define (db:get-count-tests-running-for-run-id dbstruct run-id)
(define (db:get-count-tests-running-for-run-id dbstruct area-dat run-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');" run-id))))

;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;; 
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
(define (db:get-count-tests-running-for-testname dbstruct area-dat run-id testname)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname))))

(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
  (let* ((dbdat (db:get-db dbstruct #f))
(define (db:get-count-tests-running-in-jobgroup dbstruct area-dat run-id jobgroup)
  (let* ((dbdat (db:get-db dbstruct area-dat #f))
	 (db    (db:dbdat-get-db dbdat)))
  (if (not jobgroup)
      0 ;; 
      (let ((testnames '()))
	;; get the testnames
	(db:delay-if-busy dbdat)
	(db:delay-if-busy dbdat area-dat)
	(sqlite3:for-each-row
	 (lambda (testname)
	   (set! testnames (cons testname testnames)))
	 db
	 "SELECT testname FROM test_meta WHERE jobgroup=?"
	 jobgroup)
	;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?
	(if (not (null? testnames))
	    (db:with-db
	     dbstruct
	     dbstruct area-dat
	     run-id
	     #f
	     (lambda (db)
	       (sqlite3:first-result
		db
		(conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
		      (string-intersperse testnames "','")
		      "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ???
	       0)))))))
             ;; DEBUG FIXME - need to merge this v.155 query correctly   
             ;; AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?)
             ;; AND NOT (uname = 'n/a' AND item_path = '');"

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining dbstruct run-id)
(define (db:estimated-tests-remaining dbstruct area-dat run-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
      "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ');"))))

;; map run-id, testname item-path to test-id
(define (db:get-test-id dbstruct run-id testname item-path)
(define (db:get-test-id dbstruct area-dat run-id testname item-path)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (db:first-result-default
      db
      "SELECT id FROM tests WHERE testname=? AND item_path=?;"
      #f ;; the default
      testname item-path))))

;; overload the unused attemptnum field for the process id of the runscript or 
;; ezsteps step script in progress
;;
(define (db:test-set-top-process-pid dbstruct run-id test-id pid)
(define (db:test-set-top-process-pid dbstruct area-dat run-id test-id pid)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET attemptnum=? WHERE id=?;"
		      pid test-id))))

(define (db:test-get-top-process-pid dbstruct run-id test-id)
(define (db:test-get-top-process-pid dbstruct area-dat run-id test-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (db:first-result-default 
      db
      "SELECT attemptnum FROM tests WHERE id=?;"
      #f

		(loop (car tal)(cdr tal)(+ indx 1)))))))

(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))


;; NOTE: Use db:test-get* to access records
;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
(define (db:get-all-tests-info-by-run-id dbstruct run-id)
(define (db:get-all-tests-info-by-run-id dbstruct area-dat run-id)
  (let* ((dbdat (if (vector? dbstruct)
		    (db:get-db dbstruct run-id)
		    (db:get-db dbstruct area-dat run-id)
		    dbstruct)) ;; still settling on when to use dbstruct or dbdat
	 (db    (db:dbdat-get-db dbdat))
	 (res '()))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
       ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14     15        16
       (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
		       res)))
     db
     (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
     run-id)
    res))

(define (db:replace-test-records dbstruct run-id testrecs)
  (db:with-db dbstruct run-id #t 
(define (db:replace-test-records dbstruct area-dat run-id testrecs)
  (db:with-db dbstruct area-dat run-id #t 
	      (lambda (db)
		(let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
		       (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");"))
		       (qry    (sqlite3:prepare db qrystr)))
		  (debug:print 0 "INFO: migrating test records for run with id " run-id)
		  (sqlite3:with-transaction
		   db

       (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
	 (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
     testrecs)))
	
;; 1. move test ids into the 30k * run_id range
;; 2. move step ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-for-migration mtdb)
  (let* ((run-ids (db:get-all-run-ids mtdb)))
(define (db:prep-megatest.db-for-migration mtdb area-dat)
  (let* ((run-ids (db:get-all-run-ids mtdb area-dat)))
    (for-each 
     (lambda (run-id)
       (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
	 (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
     run-ids)))

;; Get test data using test_id
(define (db:get-test-info-by-id dbstruct run-id test-id)
(define (db:get-test-info-by-id dbstruct area-dat run-id test-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
	(lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived)
	  ;;             0    1       2      3      4        5       6      7        8     9     10      11          12          13           14         15          16
	  (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived)))
	db
	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;")
	test-id)
       res))))

;; Use db:test-get* to access
;; Get test data using test_ids. NB// Only works within a single run!!
;;
(define (db:get-test-info-by-ids dbstruct run-id test-ids)
(define (db:get-test-info-by-ids dbstruct area-dat run-id test-ids)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (let ((res '()))
       (sqlite3:for-each-row
	(lambda (a . b)
	  ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
	  (set! res (cons (apply vector a b) res)))
	db
	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
	      (string-intersperse (map conc test-ids) ",") ");"))
       res))))

(define (db:get-test-info dbstruct run-id testname item-path)
(define (db:get-test-info dbstruct area-dat run-id testname item-path)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row
	(lambda (a . b)
	  (set! res (apply vector a b)))
	db
	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;")
	test-name item-path)
       res))))

(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
(define (db:test-get-rundir-from-test-id dbstruct area-dat run-id test-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (db:first-result-default
      db
      "SELECT rundir FROM tests WHERE id=?;"
      #f ;; default result
      test-id))))

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

(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
(define (db:teststep-set-status! dbstruct area-dat run-id test-id teststep-name state-in status-in comment logfile)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #t
   (lambda (db)
     (sqlite3:execute 
      db
      "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 "")))))
   
;; db-get-test-steps-for-run
(define (db:get-steps-for-test dbstruct run-id test-id)
(define (db:get-steps-for-test dbstruct area-dat run-id test-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (let* ((res '()))
       (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)))
	db
	"SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
	test-id)
       (reverse res)))))

(define (db:get-steps-data dbstruct run-id test-id)
(define (db:get-steps-data dbstruct area-dat run-id test-id)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (let ((res '()))
       (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)))

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

;; WARNING: Do NOT call this for the parent test on an iterated test
;; Roll up test_data pass/fail results
;; 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 dbstruct run-id test-id status)
  (let* ((dbdat      (db:get-db dbstruct run-id))
(define (db:test-data-rollup dbstruct area-dat run-id test-id status)
  (let* ((dbdat      (db:get-db dbstruct area-dat run-id))
	 (db         (db:dbdat-get-db dbdat))
	 (fail-count 0)
	 (pass-count 0))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (fcount pcount)
       (set! fail-count fcount)
       (set! pass-count pcount))
     db 
     "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
             (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
     test-id test-id)
    ;; Now rollup the counts to the central megatest.db
    (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id))
    ;; if the test is not FAIL then set status based on the fail and pass counts.
    (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id))))

(define (db:csv->test-data dbstruct run-id test-id csvdata)
(define (db:csv->test-data dbstruct area-dat run-id test-id csvdata)
  (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
  (let* ((dbdat   (db:get-db dbstruct run-id))
  (let* ((dbdat   (db:get-db dbstruct area-dat run-id))
	 (db      (db:dbdat-get-db dbdat))
	 (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)

			 ((>)  (if (>  value expected) "pass" "fail"))
			 ((<)  (if (<  value expected) "pass" "fail"))
			 ((>=) (if (>= value expected) "pass" "fail"))
			 ((<=) (if (<= value expected) "pass" "fail"))
			 (else (conc "ERROR: bad tol comparator " tol))))))
	 (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value 
		      ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
	 (db:delay-if-busy dbdat)
	 (db:delay-if-busy dbdat area-dat)
	 (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
			  test-id category variable value expected tol units (if comment comment "") status type)))
     csvlist)))

;;======================================================================
;; Misc. test related queries
;;======================================================================

(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
  (let* ((dbdat    (db:get-db dbstruct #f))
(define (db:get-run-ids-matching-target dbstruct area-dat keynames target res runname testpatt statepatt statuspatt)
  (let* ((dbdat    (db:get-db dbstruct area-dat #f))
	 (db       (db:dbdat-get-db dbdat))
	 (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 "';"))))
    ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n  runsqry=" runsqry "\n  tstsqry=" testqry)
    (sqlite3:for-each-row
     (lambda (rid)
       (set! row-ids (cons rid row-ids)))
     runsqry)
    (sqlite3:finalize! runsqry)
    row-ids))

(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
(define (db:test-get-paths-matching-keynames-target-new dbstruct area-dat run-id keynames target res testpatt statepatt statuspatt runname)
  (let* ((testqry (tests:match->sqlqry testpatt))
	 (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
    (db:with-db
     dbstruct
     dbstruct area-dat
     run-id
     #f
     (lambda (db)
       (sqlite3:for-each-row 
	(lambda (p)
	  (set! res (cons p res)))
	db
	tstsqry)
       res))))

(define (db:test-toplevel-num-items dbstruct run-id testname)
(define (db:test-toplevel-num-items dbstruct area-dat run-id testname)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (let ((res 0))
       (sqlite3:for-each-row
	(lambda (num-items)
	  (set! res num-items))

	   (lambda ()(deserialize)))
	 (begin
	   (debug:print 0 "ERROR: reception failed. Received " msg " but cannot translate it.")
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg)))

(define (db:test-set-status-state dbstruct run-id test-id status state msg)
  (let ((dbdat  (db:get-db dbstruct run-id)))
(define (db:test-set-status-state dbstruct area-dat run-id test-id status state msg)
  (let ((dbdat  (db:get-db dbstruct area-dat run-id)))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
	(db:general-call dbdat 'set-test-start-time (list test-id)))
    (if msg
	(db:general-call dbdat 'state-status-msg (list state status msg test-id))
	(db:general-call dbdat 'state-status     (list state status test-id)))))

(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status)
(define (db:roll-up-pass-fail-counts dbstruct area-dat run-id test-name item-path status)
  (if (and (not (equal? item-path ""))
	   (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP" "LAUNCHED")))
      (let ((dbdat (db:get-db dbstruct run-id)))
      (let ((dbdat (db:get-db dbstruct area-dat run-id)))
	(db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name))
	(if (equal? status "RUNNING")
	    (db:general-call dbdat 'top-test-set-running (list test-name))
	    (if (equal? status "LAUNCHED")
		(db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))
		(db:general-call dbdat 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name))))
	#f)
      #f))

(define (db:test-get-logfile-info dbstruct run-id test-name)
(define (db:test-get-logfile-info dbstruct area-dat run-id test-name)
  (db:with-db
   dbstruct
   dbstruct area-dat
   run-id
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row 
	(lambda (path final_logf)
	  ;; (let ((path       (sdb:qry 'getstr path-id))

			       immediate
			       flush
			       sync
			       set-verbosity
			       killserver
			       ))

(define (db:login dbstruct calling-path calling-version run-id client-signature)
(define (db:login dbstruct area-dat area-dat calling-path calling-version run-id client-signature)
  (cond 
   ((not (equal? calling-path *toppath*))
    (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
   ((not (equal? calling-path (megatest:area-path area-dat)))
    (list #f "Login failed due to mismatch paths: " calling-path ", " (megatest:area-path area-dat)))
   ((not (equal? *run-id* run-id))
    (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
   ((not (equal? megatest-version calling-version))
    (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version))
   (else
    (hash-table-set! *logged-in-clients* client-signature (current-seconds))
    '(#t "successful login"))))

(define (db:general-call dbdat stmtname params)
(define (db:general-call dbdat stmtname params area-dat)
  (let ((query (let ((q (alist-ref (if (string? stmtname)
				       (string->symbol stmtname)
				       stmtname)
				   db:queries)))
 		 (if q (car q) #f))))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (apply sqlite3:execute (db:dbdat-get-db dbdat) query params)
    #t)) ;; BUG or Sillyness, why do I return #t instead of the query result?

;; get the previous records for when these tests were run where all keys match but runname
;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
;; can use wildcards. Also can likely be factored in with get test paths?
;;
;; Run this remotely!!
;;
(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
  (let* ((dbdat   (db:get-db dbstruct #f))
(define (db:get-matching-previous-test-run-records dbstruct area-dat run-id test-name item-path)
  (let* ((dbdat   (db:get-db dbstruct area-dat #f))
	 (db      (db:dbdat-get-db dbdat))
	 (keys    (db:get-keys db))
	 (keys    (db:get-keys db area-dat))
	 (selstr  (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
	 (qrystr  (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
	 (keyvals #f)
	 (tests-hash (make-hash-table)))
    ;; first look up the key values from the run selected by run-id
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row 
     (lambda (a . b)
       (set! keyvals (cons a b)))
     db
     (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
    (if (not keyvals)
	'()
	(let ((prev-run-ids '()))
	  (apply sqlite3:for-each-row
		 (lambda (id)
		   (set! prev-run-ids (cons id prev-run-ids)))
		 db
		 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
	  ;; collect all matching tests for the runs then
	  ;; extract the most recent test and return that.
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals 
		       ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) '()  ;; no previous runs? return null
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
		(let ((results (db:get-tests-for-run dbstruct area-dat run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name 
			       ", item-path " item-path " results: " (intersperse results "\n"))
		  ;; Keep only the youngest of any test/item combination
		  (for-each 
		   (lambda (testdat)
		     (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
			    (stored-test   (hash-table-ref/default tests-hash full-testname #f)))
		       (if (or (not stored-test)
			       (and stored-test
				    (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
			   ;; this test is younger, store it in the hash
			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

(define (db:delay-if-busy dbdat #!key (count 6))
  (if (not (configf:lookup *configdat* "server" "delay-on-busy"))
(define (db:delay-if-busy dbdat area-dat #!key (count 6))
  (if (not (configf:lookup (megatest:area-configdat area-dat) "server" "delay-on-busy"))
      (and dbdat (db:dbdat-get-db dbdat))
      (if dbdat
	  (let* ((dbpath (db:dbdat-get-path dbdat))
		 (db     (db:dbdat-get-db   dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
		 (dbfj   (conc dbpath "-journal")))
	    (if (handle-exceptions
		 exn
		 (begin
		   (debug:print-info 0 "WARNING: failed to test for existance of " dbfj)
		   (thread-sleep! 1)
		   (db:delay-if-busy count (- count 1)))
		   (db:delay-if-busy dbdat area-dat count: (- count 1)))
		 (file-exists? dbfj))
		(case count
		  ((6)
		   (thread-sleep! 0.2)
		   (db:delay-if-busy count: 5))
		   (db:delay-if-busy dbdat area-dat count: 5))
		  ((5)
		   (thread-sleep! 0.4)
		   (db:delay-if-busy count: 4))
		   (db:delay-if-busy dbdat area-dat count: 4))
		  ((4)
		   (thread-sleep! 0.8)
		   (db:delay-if-busy count: 3))
		   (db:delay-if-busy dbdat area-dat count: 3))
		  ((3)
		   (thread-sleep! 1.6)
		   (db:delay-if-busy count: 2))
		   (db:delay-if-busy dbdat area-dat count: 2))
		  ((2)
		   (thread-sleep! 3.2)
		   (db:delay-if-busy count: 1))
		   (db:delay-if-busy dbdat area-dat count: 1))
		  ((1)
		   (thread-sleep! 6.4)
		   (db:delay-if-busy count: 0))
		   (db:delay-if-busy dbdat area-dat count: 0))
		  (else
		   (debug:print-info 0 "delaying db access due to high database load.")
		   (thread-sleep! 12.8))))
	    db)
	  "bogus result from db:delay-if-busy")))

(define (db:test-get-records-for-index-file dbstruct run-id test-name)
(define (db:test-get-records-for-index-file dbstruct area-dat run-id test-name)
  (let ((res '()))
    (db:with-db
     dbstruct
     dbstruct area-dat
     run-id
     #f
     (lambda (db)
       (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 testname=? AND item_path != '';"
	test-name)
       res))))

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

;; read the record given a testname
(define (db:testmeta-get-record dbstruct testname)
(define (db:testmeta-get-record dbstruct area-dat testname)
  (let ((res #f))
    (db:with-db
     dbstruct
     dbstruct area-dat
     #f
     #f
     (lambda (db)
       (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 dbstruct testname)
  (db:with-db dbstruct #f #f 
(define (db:testmeta-add-record dbstruct area-dat testname)
  (db:with-db dbstruct area-dat #f #f 
	      (lambda (db)
		(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 dbstruct testname field value)
  (db:with-db dbstruct #f #f 
(define (db:testmeta-update-field dbstruct area-dat testname field value)
  (db:with-db dbstruct area-dat #f #f 
	      (lambda (db)
		(sqlite3:execute 
		 db
		 (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))))

(define (db:testmeta-get-all dbstruct)
  (db:with-db dbstruct #f #f 
(define (db:testmeta-get-all dbstruct area-dat)
  (db:with-db dbstruct area-dat #f #f 
	      (lambda (db)
		(let ((res '()))
		  (sqlite3:for-each-row
		   (lambda (a . b)
		     (set! res (cons (apply vector a b) res)))
		   db
		   "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")

;;    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 dbstruct run-id waitons ref-item-path mode)
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f))
;; (define (db:get-prereqs-not-met dbstruct area-dat run-id waitons ref-item-path mode)
(define (db:get-prereqs-not-met dbstruct area-dat run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f))
  (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
	   ;; next should be using mt:get-tests-for-run?
	   (let ((tests             (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
	   (let ((tests             (db:get-tests-for-run-state-status dbstruct area-dat 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))

;; Extract ods file from the db
;;======================================================================

;; NOT REWRITTEN YET!!!!!

;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
(define (db:extract-ods-file dbstruct area-dat outputfile keypatt-alist runspatt pathmod)
  (let* ((keysstr  (string-intersperse (map car keypatt-alist) ","))
	 (keyqry   (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
	 (numkeys  (length keypatt-alist))
	 (test-ids '())
	 (windows  (and pathmod (substring-index "\\" pathmod)))
	 (tempdir  (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
	 (runsheader (append (list "Run Id" "Runname") ; 0 1

(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.
;; A single data structure for all the data used in a dashboard for
;; a given area.
;;
;; 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-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-get-area-path     vec)    (vector-ref vec 21))

(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-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))
(define (dboard:data-set-area-path!     vec val)(vector-set! vec 21 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))

;;======================================================================
;; D O T F I L E
;;======================================================================

;; write a sexp list to fname
;;
(define (dcommon:write-dotfile fname dat)
  (with-output-to-file fname
    (lambda ()
      (pp dat))))

(define (dcommon:read-dotfile fname)
  (if (file-exists? fname)
      (with-input-from-file fname
	(lambda ()
	  (read)))
      '()))       

;; gets the name for the file ~/.megatest/<name>
;; creates .megatest dir if not there
;;
(define (dcommon:get-dot-file-pathn name)
  (let* ((dot-dir (conc (get-environment-variable "HOME") "/.megatest"))
	 (dfile   (conc dot-dir "/" name)))
    (if (not (file-exists? dot-dir))
	(create-directory dot-dir))
    dfile))

;; dat is the top level data stucture that contains all the info being 
;; displayed in all runs etc.
;;
(define (dcommon:dotfiles-save-areas data)
  (let* ((areas-dat   (dcommon:data-get-areas data))
	 (areas-dfile (dcommon:get-dot-file-pathn "areas")))
    (dcommon:write-dotfile areas-dfile areas-dat)))

;; returns alist of area => path
;;
(define (dcommon:data-get-areas data)
  (let ((area-names (hash-table-keys data)))
    (map (lambda (area-name)
	   (cons area-name 
		 (dboard:data-get-area-path (hash-table-ref data area-name))))
	 area-names)))

;; Fill the hash table data with area => area-record
;;
(define (dcommon:read-areas-init-data data)
  (let* ((dfile       (dcommon:get-dot-file-pathn "areas"))
	 (areas-dfile (dcommon:read-dotfile dfile)))
    (for-each
     (lambda (area)
       (let ((rec (vector 25 #f)))
	 (dboard:data-set-area-path! rec (cdr area))
	 (dboard:data-set-updaters!  rec (make-hash-table))
	 (hash-table-set! data (car area) rec)))
     areas-dfile)))

;;======================================================================
;; 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))

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

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

    (iup:attribute-set! general-matrix "WIDTH1" "150")
    (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*)
    ;; (iup:attribute-set! general-matrix "2:1" toppath)
    ;; Megatest version
    (iup:attribute-set! general-matrix "2:0" "Version")
    (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

    general-matrix))

(define (dcommon:run-stats dbstruct)

    (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* ((tdbdat         (tasks:open-db))
(define (dcommon:servers-table area-dat)
  (let* ((tdbdat         (tasks:open-db area-dat))
	 (colnum         0)
	 (rownum         0)
	 (servers-matrix (iup:matrix #:expand "YES"
				     #:numcol 7
				     #:numcol-visible 7
				     #:numlin-visible 5
				     ))
	 (colnames       (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
	 (updater        (lambda ()
			   (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat))))
			   (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat area-dat))))
			     (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)

   ;;      		       (system cmd)))))
   ;;    servers-matrix
   ;;   )))
    servers-matrix
    ))

;; The main menu
(define (dcommon:main-menu)
(define (dcommon:main-menu data)
  (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 "Open"  action: (lambda (obj)
							    (let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
								   (fd        (iup:file-dialog #:dialogtype "DIR"))
								   (top       (iup:show fd #:modal? "YES")))
							      (iup:attribute-set! source-tb "VALUE"
										  (iup:attribute fd "VALUE"))
							      (iup:destroy! fd))))
			   ;; (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
		       ;;  )					     
		       ))))
			   (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
			   ;;  )					     
			   ))))

;;======================================================================
;; CANVAS STUFF FOR TESTS
;;======================================================================

(define (dcommon:draw-test cnv x y w h name selected)
  (let* ((llx x)

		  (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))))
		      (cdb:roll-up-pass-fail-counts (common:get-remote remote run-id) 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))

	   (set! res adr)))
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

(define (http-transport:run hostn run-id server-id)
(define (http-transport:run hostn run-id server-id area-dat)
  (debug:print 2 "Attempting to start the server ...")
  (let* ((configdat       (megatest:area-configdat area-dat))
  (let* ((db              #f) ;;        (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
	 (db              #f) ;;        (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
	 (hostname        (get-host-name))
	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname))) 
	 (start-port      (portlogger:open-run-close portlogger:find-port))
	 (link-tree-path  (configf:lookup *configdat* "setup" "linktree")))
	 (start-port      (portlogger:open-run-close (lambda (db)
						       (portlogger:find-port db area-dat))
						     area-dat))
	 (link-tree-path  (configf:lookup configdat "setup" "linktree")))
    ;; (set! db *inmemdb*)
    (debug:print-info 0 "portlogger recommended port: " start-port)
    (root-path     (if link-tree-path 
		       link-tree-path
		       (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
    (handle-directory spiffy-directory-listing)
    (handle-exception (lambda (exn chain)

				 ;; This is were we set up the database connections
			       (let* (($   (request-vars source: 'both))
				      (dat ($ 'dat))
				      (res #f))
				 (cond
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "api"))
				   (send-response body:    (api:process-request *inmemdb* $) ;; the $ is the request vars proc
				   (send-response body:    (api:process-request *inmemdb* area-dat $) ;; the $ is the request vars proc
						  headers: '((content-type text/plain)))
				   (mutex-lock! *heartbeat-mutex*)
				   (set! *last-db-access* (current-seconds))
				   (mutex-unlock! *heartbeat-mutex*))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ ""))
				   (send-response body: (http-transport:main-page)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "runs"))
				   (send-response body: (http-transport:main-page)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ any))
				   (send-response body: "hey there!\n"
						  headers: '((content-type text/plain))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "hey"))
				   (send-response body: "hey there!\n"
						  headers: '((content-type text/plain))))
				  (else (continue))))))))
    (http-transport:try-start-server run-id ipaddrstr start-port server-id)))
    (http-transport:try-start-server run-id ipaddrstr start-port server-id area-dat)))

;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server run-id ipaddrstr portnum server-id)
  (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
	(tdbdat          (tasks:open-db)))
(define (http-transport:try-start-server run-id ipaddrstr portnum server-id area-dat)
  (let ((config-hostname (configf:lookup (megatest:area-configdat area-dat) "server" "hostname"))
	(tdbdat          (tasks:open-db area-dat)))
    (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname)
    (handle-exceptions
     exn
     (begin
       (print-error-message exn)
       (if (< portnum 64000)
	   (begin 
	     (debug:print 0 "WARNING: attempt to start server failed. Trying again ...")
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 0 "exn=" (condition->list exn))
	     (portlogger:open-run-close portlogger:set-failed portnum)
	     (portlogger:open-run-close (lambda (db portnum)
					  (portlogger:set-failed db area-dat portnum))
					area-dat portnum)
	     (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port")
	     (thread-sleep! 0.1)

	     ;; get_next_port goes here
	     (http-transport:try-start-server run-id
					      ipaddrstr
					      (portlogger:open-run-close portlogger:find-port)
					      server-id))
					      (portlogger:open-run-close 
					       (lambda (db)
						 (portlogger:find-port db area-dat))
					       area-dat)
					      server-id
					      area-dat))
	   (begin
	     (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server")
	     (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat area-dat) run-id ipaddrstr portnum " http-transport:try-start-server")
	     (print "ERROR: Tried and tried but could not start the server"))))
     ;; any error in following steps will result in a retry
     (set! *server-info* (list ipaddrstr portnum))
     (tasks:server-set-interface-port 
		     (db:delay-if-busy tdbdat)
		     (db:delay-if-busy tdbdat area-dat)
		     server-id 
		     ipaddrstr portnum)
     (debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum)
     ;; This starts the spiffy server
     ;; NEED WAY TO SET IP TO #f TO BIND ALL
     ;; (start-server bind-address: ipaddrstr port: portnum)
     (if config-hostname ;; this is a hint to bind directly
	 (start-server port: portnum bind-address: (if (equal? config-hostname "-")
						       ipaddrstr
						       config-hostname))
	 (start-server port: portnum))
     ;;  (portlogger:open-run-close portlogger:set-port portnum "released")
     (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server")
     (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat area-dat) run-id ipaddrstr portnum " http-transport:try-start-server")
     (debug:print 1 "INFO: server has been stopped"))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

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

(define (http-transport:inc-requests-and-prep-to-close-all-connections)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))

;; Send "cmd" with json payload "params" to serverdat and receive result
;;
(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3))
(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)(remote #f))
  (let* ((fullurl    (if (vector? serverdat)
			 (http-transport:server-dat-get-api-req serverdat)
			 (begin
			   (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
			   (exit 1))))
	 (res        #f)
	 (success    #t)

					 (db:string->obj 
					  (handle-exceptions
					   exn
					   (begin
					     (set! success #f)
					     (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ".")
					     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
					     (hash-table-delete! *runremote* run-id)
					     (common:del-remote! remote run-id)
					     ;; Killing associated server to allow clean retry.")
					     ;; (tasks:kill-server-run-id run-id)  ;; better to kill the server in the logic that called this routine?
					     (mutex-unlock! *http-mutex*)
					     ;;; (signal (make-composite-condition
					     ;;;          (make-property-condition 'commfail 'message "failed to connect to server")))
					     ;;; "communications failed"
					     (db:obj->string #f))

		   (pp (vector-ref res 1) (current-error-port))
		   (signal (vector-ref result 0))))
	     (signal (make-composite-condition
		      (make-property-condition 
		       'timeout
		       'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))

;; careful closing of connections stored in *runremote*
;; careful closing of connections stored in (common:get-remote remote)
;;
(define (http-transport:close-connections run-id)
  (let* ((server-dat (hash-table-ref/default *runremote* run-id #f)))
  (let* ((server-dat (common:get-remote remote run-id)))
    (if (vector? server-dat)
	(let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
	  (close-connection! api-dat)
	  #t)
	#f)))

	 (api-req      (make-request method: 'POST uri: api-uri))
	 (server-dat   (vector iface port api-uri api-url api-req (current-seconds))))
    server-dat))

;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running server-id run-id)
(define (http-transport:keep-running server-id run-id area-dat)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (debug:print-info 0 "Starting the sync-back, keep alive thread in server for run-id=" run-id)
  (let* ((tdbdat      (tasks:open-db))
  (let* ((tdbdat      (tasks:open-db area-dat))
	 (server-info (let loop ((start-time (current-seconds))
				 (changed    #t)
				 (last-sdat  "not this"))
                        (let ((sdat #f))
			  (thread-sleep! 0.01)
			  (debug:print-info 0 "Waiting for server alive signature")
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if (and sdat
				   (not changed)
				   (> (- (current-seconds) start-time) 2))
			      sdat
                              (begin
				(debug:print-info 0 "Still waiting, last-sdat=" last-sdat)
                                (sleep 4)
				(if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
				    (begin
				      (debug:print 0 "ERROR: transport appears to have died, exiting server " server-id " for run " run-id)
				      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
				      (tasks:server-delete-record (db:delay-if-busy tdbdat area-dat) server-id "failed to start, never received server alive signature")
				      (exit))
				    (loop start-time
					  (equal? sdat last-sdat)
					  sdat)))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)
	 (server-timeout (server:get-timeout)))
	 (server-timeout (server:get-timeout area-dat)))
    (let loop ((count         0)
	       (server-state 'available)
	       (bad-sync-count 0))

      ;; Use this opportunity to sync the inmemdb to db
      (if *inmemdb* 
	  (let ((start-time (current-milliseconds))
		(sync-time  #f)
		(rem-time   #f))
	    ;; inmemdb is a dbstruct
	    (condition-case
	     (db:sync-touched *inmemdb* *run-id* force-sync: #t)
	     (db:sync-touched *inmemdb* area-dat *run-id* force-sync: #t)
	     ((sync-failed)(cond
			    ((> bad-sync-count 10) ;; time to give up
			     (http-transport:server-shutdown server-id port))
			     (http-transport:server-shutdown server-id port area-dat))
			    (else ;; (> bad-sync-count 0)  ;; we've had a fail or two, delay and loop
			     (thread-sleep! 5)
			     (loop count server-state (+ bad-sync-count 1)))))
	     ((exn)
	      (debug:print 0 "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server")
	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running crashed")
	      (tasks:server-delete-record (db:delay-if-busy tdbdat area-dat) server-id " http-transport:keep-running crashed")
	      (exit)))
	    (set! sync-time  (- (current-milliseconds) start-time))
	    (set! rem-time (quotient (- 4000 sync-time) 1000))
	    (debug:print 2 "SYNC: time= " sync-time ", rem-time=" rem-time)
	    
	    (if (and (<= rem-time 4)
		     (> rem-time 0))
		(thread-sleep! rem-time)
		(thread-sleep! 4))) ;; fallback for if the math is changed ...

	  ;;
	  ;; no *inmemdb* yet, set running after our first pass through and start the db
	  ;;
	  (if (eq? server-state 'available)
	      (let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers
	      (let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat area-dat) run-id))) ;; try to ensure no double registering of servers
		(if (equal? new-server-id server-id)
		    (begin
		      (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
		      (tasks:server-set-state! (db:delay-if-busy tdbdat area-dat) server-id "dbprep")
		      (thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
		      (set! *inmemdb*  (db:setup run-id))
		      (set! *inmemdb*  (db:setup run-id area-dat))
		      ;; force initialization
		      ;; (db:get-db *inmemdb* #t)
		      (db:get-db *inmemdb* run-id)
		      (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running"))
		      (db:get-db *inmemdb* area-dat run-id)
		      (tasks:server-set-state! (db:delay-if-busy tdbdat area-dat) server-id "running"))
		    (begin ;; gotta exit nicely
		      (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
		      (http-transport:server-shutdown server-id port))))))
		      (tasks:server-set-state! (db:delay-if-busy tdbdat area-dat) server-id "collision")
		      (http-transport:server-shutdown server-id port area-dat))))))
      
      (if (< count 1) ;; 3x3 = 9 secs aprox
	  (loop (+ count 1) 'running bad-sync-count))
      
      ;; Check that iface and port have not changed (can happen if server port collides)
      (mutex-lock! *heartbeat-mutex*)
      (set! sdat *server-info*)

      (set! last-access *last-db-access*)
      (mutex-unlock! *heartbeat-mutex*)

      ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
      ;;
      ;; no_traffic, no running tests, if server 0, no running servers
      ;;
      ;; (let ((wait-on-running (configf:lookup *configdat* "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out)
      ;; (let ((wait-on-running (configf:lookup configdat "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out)
      ;;
      (if (and *server-run*
	       (> (+ last-access server-timeout)
		  (current-seconds)))
	  (begin
	    (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
	    ;;
	    ;; Consider implementing some smarts here to re-insert the record or kill self is
	    ;; the db indicates so
	    ;;
	    ;; (if (tasks:server-am-i-the-server? tdb run-id)
	    ;;     (tasks:server-set-state! tdb server-id "running"))
	    ;;
	    (loop 0 server-state bad-sync-count))
	  (http-transport:server-shutdown server-id port)))))
	  (http-transport:server-shutdown server-id port area-dat)))))

(define (http-transport:server-shutdown server-id port)
  (let ((tdbdat (tasks:open-db)))
(define (http-transport:server-shutdown server-id port area-dat)
  (let ((tdbdat (tasks:open-db area-dat)))
    (debug:print-info 0 "Starting to shutdown the server.")
    ;; need to delete only *my* server entry (future use)
    (set! *time-to-exit* #t)
    (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t))
    (if *inmemdb* (db:sync-touched *inmemdb* area-dat *run-id* force-sync: #t))
    ;;
    ;; start_shutdown
    ;;
    (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
    (portlogger:open-run-close portlogger:set-port port "released")
    (tasks:server-set-state! (db:delay-if-busy tdbdat area-dat) server-id "shutting-down")
    (portlogger:open-run-close 
     (lambda (db port value)
       (portlogger:set-port db port value))
     area-dat port "released")
    (thread-sleep! 5)
    (debug:print-info 0 "Max cached queries was    " *max-cache-size*)
    (debug:print-info 0 "Number of cached writes   " *number-of-writes*)
    (debug:print-info 0 "Average cached write time "
		      (if (eq? *number-of-writes* 0)
			  "n/a (no writes)"
			  (/ *writes-total-delay*
			     *number-of-writes*))
		      " ms")
    (debug:print-info 0 "Number non-cached queries "  *number-non-write-queries*)
    (debug:print-info 0 "Average non-cached time   "
		      (if (eq? *number-non-write-queries* 0)
			  "n/a (no queries)"
			  (/ *total-non-write-delay* 
			     *number-non-write-queries*))
		      " ms")
    (debug:print-info 0 "Server shutdown complete. Exiting")
    (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
    (tasks:server-delete-record (db:delay-if-busy tdbdat area-dat) server-id " http-transport:keep-running complete")
    (exit)))

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch run-id)
  (let* ((tdbdat (tasks:open-db)))
(define (http-transport:launch run-id area-dat)
  (let* ((tdbdat (tasks:open-db area-dat)))
    (set! *run-id*   run-id)
    (if (args:get-arg "-daemonize")
	(begin
	  (daemon:ize)
	  (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
	      (begin
		(current-error-port *alt-log-file*)
		(current-output-port *alt-log-file*)))))
    (if (server:check-if-running run-id)
    (if (server:check-if-running run-id area-dat)
	(begin
	  (debug:print 0 "INFO: Server for run-id " run-id " already running")
	  (exit 0)))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat area-dat) run-id area-dat))
	       (remtries  4))
      (if (not server-id)
	  (if (> remtries 0)
	      (begin
		(thread-sleep! 2)
		(loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
		(loop (tasks:server-lock-slot (db:delay-if-busy tdbdat area-dat) run-id area-dat)
		      (- remtries 1)))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat area-dat) " http-transport:launch")
		))
	  (let* ((th2 (make-thread (lambda ()
				     (debug:print-info 0 "Server run thread started")
				     (http-transport:run 
				      (if (args:get-arg "-server")
					  (args:get-arg "-server")
					  "-")
				      run-id
				      server-id)) "Server run"))
				      server-id
				      area-dat)) "Server run"))
		 (th3 (make-thread (lambda ()
				     (debug:print-info 0 "Server monitor thread started")
				     (http-transport:keep-running server-id run-id))
				     (http-transport:keep-running server-id run-id area-dat))
				   "Keep running")))
	    (thread-start! th2)
	    (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
	    (thread-start! th3)
	    (set! *didsomething* #t)
	    (thread-join! th2)
	    (exit))))))

(define (http:ping run-id host-port)
(define (http:ping run-id host-port area-dat)
  (let* ((server-dat (http-transport:client-connect (car host-port)(cadr host-port)))
	 (login-res  (rmt:login-no-auto-client-setup server-dat run-id)))
	 (login-res  (rmt:login-no-auto-client-setup server-dat run-id area-dat)))
    (if (and (list? login-res)
	     (car login-res))
	(begin
	  (print "LOGIN_OK")
	  (exit 0))
	(begin
	  (print "LOGIN_FAILED")

     (thread-start! th1)
     (thread-join! th2))))

;;======================================================================
;; web pages
;;======================================================================

(define (http-transport:main-page)
  (let ((linkpath (root-path)))
    (conc "<head><h1>" (pathname-strip-directory *toppath*) "</h1></head>"
(define (http-transport:main-page area-dat)
  (let* ((toppath  (megatest:area-path area-dat))
	 (linkpath (root-path)))
    (conc "<head><h1>" (pathname-strip-directory toppath) "</h1></head>"
	  "<body>"
	  "Run area: " *toppath*
	  "Run area: " toppath
	  "<h2>Server Stats</h2>"
	  (http-transport:stats-table) 
	  "<hr>"
	  (http-transport:runs linkpath)
	  "<hr>"
	  (http-transport:run-stats)
	  "</body>"

	    (set! res (append res (list item)))
	    (loop (+ indx 1)
		  '()
		  #f)))
      res)))
            ;; Nope, not now, return null as of 6/6/2011
		
(define (items:check-valid-items class item)
  (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class)))
(define (items:check-valid-items class item area-dat)
  (let ((valid-values (let ((s (config-lookup (megatest:area-configdat area-dat) "validvalues" class)))
			(if s (string-split s) #f))))
    (if valid-values
	(if (member item valid-values)
	    item #f)
	item)))

(define (items:get-items-from-config tconfig)

    ;;   (if (and prevstep (file-exists? prev-env))
    ;;       (set! script (conc script "source " prev-env))))
    
    ;; call the command using mt_ezstep
    ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
    
    (debug:print 4 "script: " script)
    (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
    (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f area-dat)
    ;; now launch the actual process
    (call-with-environment-variables 
     (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
     (lambda ()
       (let* ((cmd (conc stepcmd " > " stepname ".log"))
	      (pid (process-run cmd)))
	 (rmt:test-set-top-process-pid run-id test-id pid)
	 (rmt:test-set-top-process-pid run-id test-id pid area-dat)
	 (let processloop ((i 0))
	   (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
		       (mutex-lock! m)
		       (vector-set! exit-info 0 pid)
		       (vector-set! exit-info 1 exit-status)
		       (vector-set! exit-info 2 exit-code)
		       (mutex-unlock! m)

			    (begin
			      (thread-sleep! 2)
			      (processloop (+ i 1)))))
	    (debug:print-info 0 "logpro for step " stepname " exited with code " (vector-ref exit-info 2)))))
    
    (let ((exinfo (vector-ref exit-info 2))
	  (logfna (if logpro-used (conc stepname ".html") "")))
      (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
      (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna area-dat))
    (if logpro-used
	(rmt:test-set-log! run-id test-id (conc stepname ".html")))
	(rmt:test-set-log! run-id test-id (conc stepname ".html") area-dat))
    ;; 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? (vector-ref exit-info 3) 2) 'warn) ;; rollup-status

	 (tests:test-set-status! run-id test-id next-state "PASS" #f #f))
	(else ;; 'fail
	 (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" 
	 (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
	 )))
    logpro-used))

(define (launch:execute encoded-cmd)
(define (launch:execute encoded-cmd area-dat)
  (let* ((cmdinfo   (common:read-encoded-string encoded-cmd)))
    (setenv "MT_CMDINFO" encoded-cmd)
    (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
	;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
	(let* ((testpath  (assoc/default 'testpath  cmdinfo))  ;; testpath is the test spec area
	       (top-path  (assoc/default 'toppath   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))  ;; work-area is the test run area

	  (change-directory top-path)

	  ;; (set-signal-handler! signal/int (lambda ()
					    
	  ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
	  ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
	  ;;
	  (let ((test-info (rmt:get-testinfo-state-status run-id test-id)))
	  (let ((test-info (rmt:get-testinfo-state-status run-id test-id area-dat)))
	    (if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
		(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
		(begin
		  (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed")
		  (exit))))
	  
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
	  (set! keys       (rmt:get-keys))
	  ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  (set! keys       (rmt:get-keys area-dat))
	  ;; (runs:set-megatest-env-vars run-id area-dat inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  ;; one of these is defunct/redundant ...
	  (if (not (launch:setup-for-run force: #t))
	  (if (not (launch:setup-for-run area-dat force: #t))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  (change-directory *toppath*) 
	  (change-directory toppath) 

	  ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This 
	  ;;       seems non-ideal but could well break stuff
	  ;;    BUG? BUG? BUG?

	  (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
	    ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
	  (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc  toppath "/runconfigs.config") #f #t sections: (list "default" target))))
	    ;; (setup-env-defaults (conc toppath "/runconfigs.config") run-id (make-hash-table) keyvals target)
	    ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
	    ;; Now have runconfigs data loaded, set environment vars
	    (for-each (lambda (section)
			(for-each (lambda (varval)
				    (let ((var (car varval))
					  (val (cadr varval)))
				      (if (and (string? var)(string? val))

	      (list  "MT_TEST_RUN_DIR" work-area)
	      (list  "MT_TEST_NAME" test-name)
	      (list  "MT_ITEM_INFO" (conc itemdat))
	      (list  "MT_ITEMPATH"  item-path)
	      (list  "MT_RUNNAME"   runname)
	      (list  "MT_MEGATEST"  megatest)
	      (list  "MT_TARGET"    target)
	      (list  "MT_LINKTREE"  (configf:lookup *configdat* "setup" "linktree"))
	      (list  "MT_LINKTREE"  (configf:lookup (megatest:area-configdat area-dat) "setup" "linktree"))
	      (list  "MT_TESTSUITENAME" (common:get-testsuite-name))))

	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
	  ;; (change-directory top-path)
	  ;; Can setup as client for server mode now
	  ;; (client:setup)

	  
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
	  (runs:set-megatest-env-vars run-id area-dat inkeys: keys inkeyvals: keyvals)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")
	  ;; open-run-close not needed for test-set-meta-info
	  ;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
	  ;; (tests:set-full-meta-info test-id run-id 0 work-area)
	  (tests:set-full-meta-info #f test-id run-id 0 work-area 10)

				 ;; Since we should have a clean slate at this time there is no need to do 
				 ;; any of the other stuff that tests:test-set-status! does. Let's just 
				 ;; force RUNNING/n/a
				 

				 ;; (thread-sleep! 0.3)
				 (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
				 (rmt:roll-up-pass-fail-counts run-id test-name item-path "RUNNING")
				 (rmt:roll-up-pass-fail-counts run-id test-name item-path "RUNNING" area-dat)
				 ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here

				 ;; if there is a runscript do it first
				 (if fullrunscript
				     (let ((pid (process-run fullrunscript)))
				       (rmt:test-set-top-process-pid run-id test-id pid)
				       (rmt:test-set-top-process-pid run-id test-id pid area-dat)
				       (let loop ((i 0))
					 (let-values
					  (((pid-val exit-status exit-code) (process-wait pid #t)))
					  (mutex-lock! m)
					  (vector-set! exit-info 0 pid)
					  (vector-set! exit-info 1 exit-status)
					  (vector-set! exit-info 2 exit-code)

				       (if kill-job? 
					   (begin
					     (mutex-lock! m)
					     ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
					     ;;       section and the runit section? Or add a loop that tries three times with a 1/4 second
					     ;;       between tries?
					     (let* ((pid1 (vector-ref exit-info 0))
						    (pid2 (rmt:test-get-top-process-pid run-id test-id))
						    (pid2 (rmt:test-get-top-process-pid run-id test-id area-dat))
						    (pids (delete-duplicates (filter number? (list pid1 pid2)))))
					       (if (not (null? pids))
						   (begin
						     (for-each
						      (lambda (pid)
							(handle-exceptions
							 exn

	    (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...")
	    (set! keep-going #f)
	    (thread-join! th1)
	    (thread-sleep! 1)       ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec.
	    (mutex-lock! m)
	    (let* ((item-path (item-list->path itemdat))
		   ;; only state and status needed - use lazy routine
		   (testinfo  (rmt:get-testinfo-state-status run-id test-id)))
		   (testinfo  (rmt:get-testinfo-state-status run-id test-id area-dat)))
	      ;; Am I completed?
	      (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (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

	      (tests:summarize-test run-id test-id)) ;; don't force - just update if no
	    (mutex-unlock! m)
	    (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
			 work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	    (if (not (vector-ref exit-info 1))
		(exit 4)))))))

(define (launch:read-cached-config)
  (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
      (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
			       (get-environment-variable "MT_TARGET")   "/"
			       (get-environment-variable "MT_RUNNAME")  "/"
			       ".megatest.cfg")))
	(if (file-exists? alistconfig)
	    (list (configf:read-alist alistconfig)
		  (get-environment-variable "MT_RUN_AREA_HOME"))
	    #f))
      #f)) 

(define (launch:read-megatest-config toppath)
  (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))))
    (if runname (setenv "MT_RUNNAME" runname))
    (find-and-read-config 
     (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
     environ-patt: "env-override"
     given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
     pathenvvar: "MT_RUN_AREA_HOME")))

;; set up the very basics needed for doing anything here.
(define (launch:setup-for-run #!key (force #f))
(define (launch:setup-for-run area-dat #!key (force #f))
  ;; would set values for KEYS in the environment here for better support of env-override but 
  ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to 
  ;; pass on that idea for now
  ;; special case
  (let ((configdat (megatest:area-configdat area-dat)))
  (if (or force (not (hash-table? *configdat*)))  ;; no need to re-open on every call
    (if (or force (not (hash-table? configdat)))  ;; no need to re-open on every call
      (begin
	(set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
				   (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
							    (get-environment-variable "MT_TARGET")   "/"
							    (get-environment-variable "MT_RUNNAME")  "/"
							    ".megatest.cfg")))
				     (if (file-exists? alistconfig)
					 (list (configf:read-alist alistconfig)
					       (get-environment-variable "MT_RUN_AREA_HOME"))
					 #f))
				   #f) ;; no config cached - give up
	(let* ((newconfiginfo (or (launch:read-cached-config) ;; no config cached - give up
			       (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))))
				 (if runname (setenv "MT_RUNNAME" runname))
				 (find-and-read-config 
				  (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
				  (launch:read-megatest-config (megatest:area-path area-dat))))
	       (configdat     (car  newconfiginfo))
				  environ-patt: "env-override"
				  given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
	       (toppath       (cadr newconfiginfo)))
				  pathenvvar: "MT_RUN_AREA_HOME"))))
	(set! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))
	(set! *toppath*    (if (car *configinfo*)(cadr *configinfo*) #f))
	(let* ((tmptransport (configf:lookup *configdat* "server" "transport"))
	       (transport    (if tmptransport (string->symbol tmptransport) 'http)))
	  (if (member transport '(http rpc nmsg))
	      (set! *transport-type* transport)
	      (begin
		(debug:print 0 "ERROR: Unrecognised transport " transport)
		(exit))))
	(let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical
	  (if linktree
	      (if (not (file-exists? linktree))
		  (begin
		    (handle-exceptions
		     exn
		     (begin
		       (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
		       (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
		       (exit 1))
		     (create-directory linktree #t))))
	      (begin
		(debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
		(exit 1)))
	  (if linktree
	      (let ((dbdir (conc linktree "/.db")))
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
		   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
		 (if (not (directory-exists? dbdir))(create-directory dbdir)))
		(setenv "MT_LINKTREE" linktree))
	      (begin
		(debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
		(exit 1)))
	  (if (and *toppath*
		   (directory-exists? *toppath*))
	      (setenv "MT_RUN_AREA_HOME" *toppath*)
	  (megatest:area-configinfo-set! area-dat newconfiginfo)
	  (megatest:area-configdat-set!  area-dat configdat)
	  (megatest:area-path-set!       area-dat toppath)
	  (let* ((tmptransport (configf:lookup configdat "server" "transport"))
		 (transport    (if tmptransport (string->symbol tmptransport) 'http)))
	    (if (member transport '(http rpc nmsg))
		(megatest:area-transport-set! area-dat transport)
		(begin
		  (debug:print 0 "ERROR: Unrecognised transport " transport)
		  (exit))))
	  (let ((linktree (configf:lookup configdat "setup" "linktree"))) ;; link tree is critical
	    (if linktree
		(if (not (file-exists? linktree))
		    (begin
		      (handle-exceptions
		       exn
		       (begin
			 (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
			 (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
			 (exit 1))
		       (create-directory linktree #t))))
		(begin
		  (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
		  (exit 1)))
	    (if linktree
		(let ((dbdir (conc linktree "/.db")))
		  (handle-exceptions
		   exn
		   (begin
		     (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
		     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
		   (if (not (directory-exists? dbdir))(create-directory dbdir)))
		  (setenv "MT_LINKTREE" linktree))
		(begin
		  (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
		  (exit 1)))
	    (if (and toppath
		   (directory-exists? toppath))
	      (setenv "MT_RUN_AREA_HOME" toppath)
	      (begin
		(debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
		(exit 1)))
		(exit 1))))
	  )))
  *toppath*)
	  toppath))))

(define (launch:cache-config)
(define (launch:cache-config area-dat)
  ;; if we have a linktree and -runtests and -target and the directory exists dump the config
  ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
  (let ((configdat (megatest:area-configdat area-dat)))
  (if (and *configdat* 
	   (args:get-arg "-runtests"))
      (let* ((linktree (get-environment-variable "MT_LINKTREE"))
	     (target   (common:args-get-target))
	     (runname  (or (args:get-arg "-runname")
			   (args:get-arg ":runname")))
	     (fulldir  (conc linktree "/"
			     target "/"
			     runname)))
	(debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir)
	(if (file-exists? linktree) ;; can't proceed without linktree
	    (begin
	      (if (not (file-exists? fulldir))
		  (create-directory fulldir #t)) ;; need to protect with exception handler 
	      (if (and target
		       runname
		       (file-exists? fulldir))
		  (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			(targfile (conc fulldir "/.megatest.cfg")))
		    (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
		    (configf:write-alist *configdat* tmpfile)
		    (system (conc "ln -sf " tmpfile " " targfile))
		    )))))))
    (if (and configdat 
	     (args:get-arg "-runtests"))
	(let* ((linktree (get-environment-variable "MT_LINKTREE"))
	       (target   (common:args-get-target))
	       (runname  (or (args:get-arg "-runname")
			     (args:get-arg ":runname")))
	       (fulldir  (conc linktree "/"
			       target "/"
			       runname)))
	  (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir)
	  (if (file-exists? linktree) ;; can't proceed without linktree
	      (begin
		(if (not (file-exists? fulldir))
		    (create-directory fulldir #t)) ;; need to protect with exception handler 
		(if (and target
			 runname
			 (file-exists? fulldir))
		    (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			  (targfile (conc fulldir "/.megatest.cfg")))
		      (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
		      (configf:write-alist configdat tmpfile)
		      (system (conc "ln -sf " tmpfile " " targfile))
		      ))))))))

(define (get-best-disk confdat)
  (let* ((disks    (hash-table-ref/default confdat "disks" #f))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
    (if disks 
	(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb