Megatest

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

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

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

ADTLSCR=mt_laststep mt_runstep mt_ezstep

# 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 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
filedb.o   : fdb_records.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

======================================================================
Try writing to in-memory db and every 2-5 seconds syncing to megatest.db
======================================================================

First, how much time will it take to write back the changes:

1. Get the run table

(define (get-all db)(let ((res '()))(for-each-row (lambda (a . b)(set! res (cons (apply vector a b) res))) db "SELECT * FROM tests;") res))
(define tdata (let ((start (current-milliseconds))(res (get-all *db*)))(print (- (current-milliseconds) start))res))

Result ranges from 34ms to 89ms but mostly around 40ms for 623 records on moosefs

Projecting to 15000 records:

  Slow   2 seconds to read all
  Median 1 second to read all

This seems like it would work with an update period of 2-5 seconds

TODO
----

1. open-db opens in-memory db and megatest.db, put handles in *memdb* and *db*, *memdb* is < run-id dbh >
2. Server is part of runtests 
   a. server start cycle - adapt to per run-id
      i. states; starting, started, stopping, stopped
   b. turn off write coalesing
3. Calls to -runtests, -remove-runs etc. 
   a. Might talk to running server if run specific
   b. Can talk to megatest.db but not a generally good idea
   c. Can start a runserver 
4. Dashboard is fine except for writes?

======================================================================
Routines to convert for runs.scm

cdb:remote-run db:register-run

cdb:delete-tests-in-state *runremote*
cdb:get-test-info-by-id *runremote*
cdb:remote-run db:delete-old-deleted-test-records
cdb:remote-run db:delete-run
cdb:remote-run db:delete-test-records
cdb:remote-run db:delete-tests-for-run
cdb:remote-run db:find-and-mark-incomplete
cdb:remote-run db:get-count-tests-running
cdb:remote-run db:get-count-tests-running-in-jobgroup
cdb:remote-run db:get-keys
cdb:remote-run db:get-run-info
cdb:remote-run db:get-run-key-val
cdb:remote-run db:get-run-name-from-id
cdb:remote-run db:get-steps-for-test
cdb:remote-run db:get-test-id-cached
cdb:remote-run db:get-tests-for-runs-mindata
cdb:remote-run db:lock/unlock-run
cdb:remote-run db:set-sync
cdb:remote-run db:set-tests-state-status
cdb:remote-run db:set-var
cdb:remote-run db:testmeta-add-record
cdb:remote-run db:testmeta-get-record
cdb:remote-run db:testmeta-update-field
cdb:remote-run db:update-run-event_time
cdb:remote-run instead
cdb:remote-run server:start
cdb:remote-run test:get-matching-previous-test-run-records
cdb:tests-register-test *runremote*
(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run

======================================================================

[87cbe68f31] 
[be405e8e2e]

# FROM andyjpg on #chicken

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

;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(declare (unit api))
(declare (uses rmt))
(declare (uses db))

;; These are called by the server on recipt of /api calls

(define (api:execute-requests db cmd params)
  (debug:print-info 1 "api:execute-requests cmd=" cmd " params=" params)
  (db:process-cached-writes db)
  (case (string->symbol cmd)
    ;; KEYS
    ((get-key-val-pairs)            (apply db:get-key-val-pairs db params))
    ;; TESTS
    ;; json doesn't do vectors, convert to list
    ((get-test-info-by-id)	    (vector->list (apply db:get-test-info-by-id db params)))
    ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params))
    ((testmeta-get-record)          (vector->list (apply db:testmeta-get-record db params)))
    ((test-set-state-status-by-id)  (apply db:test-set-state-status-by-id db params))
    ;; RUNS
    ((get-run-info)                 (let ((res (apply db:get-run-info db params)))
				      (list (vector-ref res 0)
					    (vector->list (vector-ref res 1)))))
    (else
     (list "ERROR" 0))))

;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request db $) ;; the $ is the request vars proc
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
	 (params  (rmt:json-str->dat paramsj))
	 (res     (api:execute-requests db cmd params)))
    (rmt:dat->json-str
     (if (or (string? res)
	     (list?   res)
	     (number? res)
	     (boolean? res))
	 res 
	 (list "ERROR" 1 cmd params res)))))

;; client:get-signature
(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)
  (let ((ok (and (socket? serverdat)
		 (cdb:logout serverdat *toppath* (client:get-signature)))))
    ok))

;; Do all the connection work, look up the transport type and set up the

;; (include "margs.scm")

(define getenv get-environment-variable)

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

;; GLOBAL GLETCHES
(define *db-keys* #f)
(define *configinfo* #f)
(define *configdat*  #f)
(define *toppath*    #f)
(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 *global-delta* 0)
(define *last-global-delta-printed* 0)

;; DATABASE
(define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs

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

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

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

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

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

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

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

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

(define *common:std-states*   
  '((0 "COMPLETED")
    (1 "NOT_STARTED")
    (2 "RUNNING")
    (3 "REMOTEHOSTSTART")
    (4 "LAUNCHED")
    (5 "KILLED")
    (6 "KILLREQ")
    (7 "STUCK")))

(define *common:std-statuses*
  '((0 "PASS")
    (1 "WARN")
    (2 "FAIL")
    (3 "CHECK")
    (4 "n/a")
    (5 "WAIVED")
    (6 "SKIP")
    (7 "DELETED")
    (8 "STUCK/DEAD")))

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

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

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

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

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

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

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

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

;;======================================================================
;; Colors
;;======================================================================
      
(define (common:name->iup-color name)
  (case (string->symbol (string-downcase name))

    (debug:check-verbosity *verbosity* debugstr)
    (if (or (args:get-arg "-debug")
	    (not (getenv "MT_DEBUG_MODE")))
	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
				    (string-intersperse (map conc *verbosity*) ",")
				    (conc *verbosity*))))))
  

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

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

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

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

;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly

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

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

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

(define (test-info-panel testdat store-label widgets)
  (iup:frame 
   #:title "Test Info" ; #:expand "YES"
   (iup:hbox ; #:expand "YES"
    (apply iup:vbox ; #:expand "YES"
	   (append (map (lambda (val)
			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Testname: "
			      "Item path: "
			      "Current state: "
			      "Current status: "
			      "Test comment: "
			      "Test id: "
			      "Test date: "))
		   (list (iup:label "" #:expand "VERTICAL"))))
    (apply iup:vbox  ; #:expand "YES"
	   (list 
	    (store-label "testname"
			 (iup:label (db:test-get-testname  testdat) #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-testname testdat)))
	    (store-label "item-path"

			 (lambda (testdat)
			   (db:test-get-comment testdat)))
	    (store-label "testid"
			 (iup:label "TestId                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (db:test-get-id testdat)))
	    (store-label "testdate" 
			 (iup:label "TestDate                           "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (seconds->work-week/day-time (db:test-get-event_time testdat))))
	    )))))

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

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

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


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

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

    ((vector-ref *state-status* 1) status color)))

(define *dashboard-test-db* #t)

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

					   (ezsteps:run-from testdat stepname #f))
					 (conc "ezstep run from step " stepname)))))
    ;; (iup:button "Refresh test data"
    ;;     	#:expand "HORIZONTAL"
    ;;     	#:action (lambda (obj)
    ;;     		   (print "Refresh test data " stepname))
    )))
;; get a pretty table to summarize steps
;;
(define (dashboard-tests:process-steps-table steps);; db test-id #!key (work-area #f))
;;  (let ((steps   (db:get-steps-for-test db test-id work-area: work-area)))
    ;; organise the steps for better readability
    (let ((res (make-hash-table)))
      (for-each 
       (lambda (step)
	 (debug:print 6 "step=" step)
	 (let ((record (hash-table-ref/default 
			res 
			(db:step-get-stepname step) 
			;;        stepname                start end status Duration  Logfile 
			(vector (db:step-get-stepname step) ""   "" ""     ""        ""))))
	   (debug:print 6 "record(before) = " record 
			"\nid:       " (db:step-get-id step)
			"\nstepname: " (db:step-get-stepname step)
			"\nstate:    " (db:step-get-state step)
			"\nstatus:   " (db:step-get-status step)
			"\ntime:     " (db:step-get-event_time step))
	   (case (string->symbol (db:step-get-state step))
	     ((start)(vector-set! record 1 (db:step-get-event_time step))
	      (vector-set! record 3 (if (equal? (vector-ref record 3) "")
					(db:step-get-status step)))
	      (if (> (string-length (db:step-get-logfile step))
		     0)
		  (vector-set! record 5 (db:step-get-logfile step))))
	     ((end)  
	      (vector-set! record 2 (any->number (db:step-get-event_time step)))
	      (vector-set! record 3 (db:step-get-status step))
	      (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
					  (endt   (any->number (vector-ref record 2))))
				      (debug:print 4 "record[1]=" (vector-ref record 1) 
						   ", startt=" startt ", endt=" endt
						   ", get-status: " (db:step-get-status step))
				      (if (and (number? startt)(number? endt))
					  (seconds->hr-min-sec (- endt startt)) "-1")))
	      (if (> (string-length (db:step-get-logfile step))
		     0)
		  (vector-set! record 5 (db:step-get-logfile step))))
	     (else
	      (vector-set! record 2 (db:step-get-state step))
	      (vector-set! record 3 (db:step-get-status step))
	      (vector-set! record 4 (db:step-get-event_time step))))
	   (hash-table-set! res (db:step-get-stepname step) record)
	   (debug:print 6 "record(after)  = " record 
			"\nid:       " (db:step-get-id step)
			"\nstepname: " (db:step-get-stepname step)
			"\nstate:    " (db:step-get-state step)
			"\nstatus:   " (db:step-get-status step)
			"\ntime:     " (db:step-get-event_time step))))
       ;; (else   (vector-set! record 1 (db:step-get-event_time step)))
       (sort steps (lambda (a b)
		     (cond
		      ((<   (db:step-get-event_time a)(db:step-get-event_time b)) #t)
		      ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) 
		       (<   (db:step-get-id a)        (db:step-get-id b)))
		      (else #f)))))
      res))

(define (dashboard-tests:get-compressed-steps test-id #!key (work-area #f))
  (if (or (not work-area)
	  (file-exists? (conc work-area "/testdat.db")))
      (let* ((steps-data  (rmt:get-steps-for-test test-id work-area))
	     (comprsteps  (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area)))
	(map (lambda (x)
	       ;; take advantage of the \n on time->string
	       (vector
		(vector-ref x 0)
		(let ((s (vector-ref x 1)))
		  (if (number? s)(seconds->time-string s) s))
		(let ((s (vector-ref x 2)))
		  (if (number? s)(seconds->time-string s) s))
		(vector-ref x 3)    ;; status
		(vector-ref x 4)
		(vector-ref x 5)))  ;; time delta
	     (sort (hash-table-values comprsteps)
		   (lambda (a b)
		     (let ((time-a (vector-ref a 1))
			   (time-b (vector-ref b 1)))
		       (if (and (number? time-a)(number? time-b))
			   (if (< time-a time-b)
			       #t
			       (if (eq? time-a time-b)
				   (string<? (conc (vector-ref a 2))
					     (conc (vector-ref b 2)))
				   #f))
			   (string<? (conc time-a)(conc time-b))))))))
      '()))

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

;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!!
;;
;; get a pretty table to summarize steps
;;
(define (dashboard-tests:process-steps-table steps);; db test-id #!key (work-area #f))
;;  (let ((steps   (db:get-steps-for-test db test-id work-area: work-area)))
    ;; organise the steps for better readability
    (let ((res (make-hash-table)))
      (for-each 
       (lambda (step)
	 (debug:print 6 "step=" step)
	 (let ((record (hash-table-ref/default 
			res 
			(tdb:step-get-stepname step) 
			;;        stepname                start end status Duration  Logfile 
			(vector (tdb:step-get-stepname step) ""   "" ""     ""        ""))))
	   (debug:print 6 "record(before) = " record 
			"\nid:       " (tdb:step-get-id step)
			"\nstepname: " (tdb:step-get-stepname step)
			"\nstate:    " (tdb:step-get-state step)
			"\nstatus:   " (tdb:step-get-status step)
			"\ntime:     " (tdb:step-get-event_time step))
	   (case (string->symbol (tdb:step-get-state step))
	     ((start)(vector-set! record 1 (tdb:step-get-event_time step))
	      (vector-set! record 3 (if (equal? (vector-ref record 3) "")
					(tdb:step-get-status step)))
	      (if (> (string-length (tdb:step-get-logfile step))
		     0)
		  (vector-set! record 5 (tdb:step-get-logfile step))))
	     ((end)  
	      (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
	      (vector-set! record 3 (tdb:step-get-status step))
	      (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
					  (endt   (any->number (vector-ref record 2))))
				      (debug:print 4 "record[1]=" (vector-ref record 1) 
						   ", startt=" startt ", endt=" endt
						   ", get-status: " (tdb:step-get-status step))
				      (if (and (number? startt)(number? endt))
					  (seconds->hr-min-sec (- endt startt)) "-1")))
	      (if (> (string-length (tdb:step-get-logfile step))
		     0)
		  (vector-set! record 5 (tdb:step-get-logfile step))))
	     (else
	      (vector-set! record 2 (tdb:step-get-state step))
	      (vector-set! record 3 (tdb:step-get-status step))
	      (vector-set! record 4 (tdb:step-get-event_time step))))
	   (hash-table-set! res (tdb:step-get-stepname step) record)
	   (debug:print 6 "record(after)  = " record 
			"\nid:       " (tdb:step-get-id step)
			"\nstepname: " (tdb:step-get-stepname step)
			"\nstate:    " (tdb:step-get-state step)
			"\nstatus:   " (tdb:step-get-status step)
			"\ntime:     " (tdb:step-get-event_time step))))
       ;; (else   (vector-set! record 1 (tdb:step-get-event_time step)))
       (sort steps (lambda (a b)
		     (cond
		      ((<   (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
		      ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) 
		       (<   (tdb:step-get-id a)        (tdb:step-get-id b)))
		      (else #f)))))
      res))

(define (dashboard-tests:get-compressed-steps db test-id)
  (let* ((steps-data  (db:get-steps-for-test db test-id))
	 (comprsteps  (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area)))
    (map (lambda (x)
	   ;; take advantage of the \n on time->string
	   (vector
	    (vector-ref x 0)
	    (let ((s (vector-ref x 1)))
	      (if (number? s)(seconds->time-string s) s))
	    (let ((s (vector-ref x 2)))
	      (if (number? s)(seconds->time-string s) s))
	    (vector-ref x 3)    ;; status
	    (vector-ref x 4)
	    (vector-ref x 5)))  ;; time delta
	 (sort (hash-table-values comprsteps)
	       (lambda (a b)
		 (let ((time-a (vector-ref a 1))
		       (time-b (vector-ref b 1)))
		   (if (and (number? time-a)(number? time-b))
		       (if (< time-a time-b)
			   #t
			   (if (eq? time-a time-b)
			       (string<? (conc (vector-ref a 2))
					 (conc (vector-ref b 2)))
			       #f))
		       (string<? (conc time-a)(conc time-b)))))))))

;;======================================================================
;;
;;======================================================================
(define (examine-test test-id) ;; run-id run-key origtest)
  (let* ((testdat       (rmt:get-test-info-by-id test-id))
	 (db            (open-db))
	 (tdb           (tdb:open-test-db-by-test-id-local test-id))
	 (testdat       (db:get-test-info-by-id db test-id))
	 (db-mod-time   0) ;; (file-modification-time db-path))
	 (last-update   0) ;; (current-seconds))
	 (request-update #t))
    (if (not testdat)
	(begin
	  (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
	  (exit 1))
	(let* ((run-id        (if testdat (db:test-get-run_id testdat) #f))
	       (keydat        (if testdat (db:get-key-val-pairs db run-id) #f))
	       (rundat        (if testdat (db:get-run-info db run-id) #f))
	       (runname       (if testdat (db:get-value-by-header (db:get-row rundat)
								  (db:get-header rundat)
								  "runname") #f))
	       ;; These next two are intentional bad values to ensure errors if they should not
	       ;; get filled in properly.
	       (logfile       "/this/dir/better/not/exist")
	       (rundir        logfile)
	       (testdat-path  (conc rundir "/testdat.db")) ;; this gets recalculated until found 
	       (teststeps     (if testdat (dashboard-tests:get-compressed-steps db test-id) '()))
	       (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	       (testname      (if testdat (db:test-get-testname testdat) "n/a"))
	       (testmeta      (if testdat 
				  (let ((tm (db:testmeta-get-record db testname)))
				    (if tm tm (make-db:testmeta)))
				  (make-db:testmeta)))

	       (keystring  (string-intersperse 
			    (map (lambda (keyval)
				   ;; (conc ":" (car keyval) " " (cadr keyval)))
				   (cadr keyval))

							      (set! testdat-path (conc rundir "/testdat.db"))
							      0))))
				    (need-update   (or (and (>= curr-mod-time db-mod-time)
							    (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
						       (> (current-milliseconds)(+ last-update 10000))     ;; force update even 10 seconds
						       request-update))
				    (newtestdat (if need-update 
						    ;; NOTE: BUG HIDER, try to eliminate this exception handler
						    (handle-exceptions
						     exn 
						     (debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))
						     (db:get-test-info-by-id db test-id )))))
			       ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time)
			       (cond
				((and need-update newtestdat)
				 (set! testdat newtestdat)
				 (set! teststeps    (dashboard-tests:get-compressed-steps db test-id))
				 (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
				 (set! rundir       (db:test-get-rundir testdat))
				 (set! testfullname (db:test-get-fullname testdat))
				 ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n    "))
				 
				 ;; I don't see why this was implemented this way. Please comment it ...
				 ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same
				 ;;     (set! db-mod-time (+ curr-mod-time 1))
				 ;;     (set! db-mod-time curr-mod-time))

				 (if (not (eq? curr-mod-time db-mod-time))
				     (set! db-mod-time curr-mod-time))
				 (set! last-update (current-milliseconds))
				 (set! request-update #f) ;; met the need ...
				 )
				(need-update ;; if this was true and yet there is no data ....
				 (db:test-set-testname! testdat "DEAD OR DELETED TEST")))
			       (if need-update

	    ;;  (test-set-status! db run-id test-name state status itemdat)
	    (set! self ; 
		  (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
			      #:title testfullname
			      (iup:vbox ; #:expand "YES"
			       ;; The run and test info
			       (iup:hbox  ; #:expand "YES"
				(run-info-panel db keydat testdat runname)
				(test-info-panel testdat store-label widgets)
				(test-meta-panel testmeta store-meta))
			       (host-info-panel testdat store-label)
			       ;; The controls
			       (iup:frame #:title "Actions" 
					  (iup:vbox
					   (iup:hbox 
					    (iup:button "View Log"      #:action viewlog     #:size "80x")
					    (iup:button "Start Xterm"   #:action xterm       #:size "80x")
					    (iup:button "Run Test"      #:action run-test    #:size "80x")
					    (iup:button "Clean Test"    #:action remove-test #:size "80x")
					    (iup:button "CleanRunExecute!"    #:action clean-run-execute #:size "80x")
					    (iup:button "Kill All Jobs" #:action kill-jobs   #:size "80x")
					    (iup:button "Close"         #:action (lambda (x)(exit)) #:size "80x"))
					   (apply 
					    iup:hbox
					    (list command-text-box command-launch-button))))
			       (set-fields-panel db test-id testdat)
			       (let ((tabs 
				      (iup:tabs
				       ;; Replace here with matrix
				       (let ((steps-matrix (iup:matrix
							    #:font   "Courier New, -8"
							    #:expand "YES"
							    #:scrollbar "YES"

					 (iup:attribute-set! steps-matrix "0:6" "Log File")
					 (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
					 ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
					 (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
					 (let ((proc
						(lambda (testdat)
						  (let ((max-row 0))
						    (if (not (null? teststeps))
							(let loop ((hed    (car teststeps))
								   (tal    (cdr teststeps))
								   (rownum 1)
								   (colnum 1))
							  (if (> rownum max-row)(set! max-row rownum))
							  (let ((val     (vector-ref hed (- colnum 1)))
								(mtrx-rc (conc rownum ":" colnum)))
							    (iup:attribute-set! steps-matrix  mtrx-rc (if val (conc val) ""))
							    (if (< colnum 6)
								(loop hed tal rownum (+ colnum 1))
								(if (not (null? tal))
								    (loop (car tal)(cdr tal)(+ rownum 1) 1))))))
						    (if (> max-row 0)
							(begin
							  ;; we are going to speculatively clear rows until we find a row that is already cleared
							  (let loop ((rownum  (+ max-row 1))
								     (colnum  0)
								     (deleted #f))

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

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

(include "common_records.scm")
(include "db_records.scm")
(include "run_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 2013

Usage: dashboard [options]

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

      (exit)))

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

(define *db* (open-db))

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! *runremote* (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (if (not (args:get-arg "-use-server"))
;; 	(set! *transport-type* 'fs) ;; force fs access
;; 	(client:launch)))
;;	  (client:launch))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db"))))
;; (client:setup *db*)

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

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

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

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

;; Update management
;;
(define *last-update*   (current-seconds))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)

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

					     (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
					     (car matching))))
			   (testname   (db:test-get-testname  test))
			   (itempath   (db:test-get-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-get-status   test))
			   (teststate  (db:test-get-state    test))
			   ;;(teststart  (db:test-get-event_time test))
			   (runtime    (db:test-get-run_duration test))
			   (buttontxt  (if (equal? teststate "COMPLETED") teststatus teststate))
			   (button     (vector-ref columndat rown))
			   (color      (car (gutils:get-color-for-state-status teststate teststatus)))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
		      (if (not (equal? curr-color color))

	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (db:get-targets *db*))
	 (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"))

				 #: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 *db* *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")

		    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)
	       (dboard:data-set-states! *data* all)
	       (dashboard:update-run-command))))
	   ;; Text box for STATES
	   (iup:frame
	    #:title "Statuses"
	    (dashboard:text-list-toggle-box 
	     (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
	     (lambda (all)
	       (dboard:data-set-statuses! *data* all)
	       (dashboard:update-run-command))))))))
      
       (iup:frame
	#:title "Tests and Tasks"
	(let* ((updater #f)

;;      )))

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary db)
  (let ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f 'return-string)))
    (iup:vbox
     (iup:split
      ;; #:value 500
      (iup:frame 
       #:title "General Info"
       (iup:hbox 

       (iup:vbox
	(dcommon:section-matrix rawconfig "server" "Varname" "Value")
	;; (iup:frame
	;; #:title "Disks Areas"
	(dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
     (iup:frame
      #:title "Run statistics"
      (dcommon:run-stats db)))))

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

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

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

;; (define (tests window-id)
(define (dashboard:one-run db)
  (let* ((tb      (iup:treebox
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
		   #:addexpanded "NO"
		   #:selection-cb
		   (lambda (obj id state)
		     ;; (print "obj: " obj ", id: " id ", state: " state)
		     (let* ((run-path (tree:node->path obj id))
			    (run-id   (tree-path->run-id (cdr run-path))))
		       (if run-id
			   (begin
			     (dboard:data-set-curr-run-id! *data* run-id)
			     (dashboard:update-run-summary-tab)))
		       ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
		       ))))
	 (run-matrix (iup:matrix
		      #:expand "YES"))
	 (updater  (lambda ()
		     (let* ((runs-dat     (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*))
			    (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)

     tb
     run-matrix)))

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

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

	      (map (lambda (status)
		     (iup:toggle status  #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *status-ignore-hash* status #t)
							  (hash-table-delete! *status-ignore-hash* status))
						      (set-bg-on-filter))))
		   (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
	     (apply 
	      iup:hbox
	      (map (lambda (state)
		     (iup:toggle state   #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *state-ignore-hash* state #t)
							  (hash-table-delete! *state-ignore-hash* state))
						      (set-bg-on-filter))))
		   (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
	     (iup:valuator #:valuechanged_cb (lambda (obj)
					       (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
						     (oldmax   (string->number (iup:attribute obj "MAX")))
						     (maxruns  *tot-run-count*))
						 (set! *start-run-offset* val)
						 (mark-for-update)
						 (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax)

					(apply iup:hbox (reverse hdrlst))
					(apply iup:hbox (reverse bdylst))))))
			 controls))
	     (tabs (iup:tabs
		    #:tabchangepos-cb (lambda (obj curr prev)
					(set! *please-update-buttons* #t)
					(set! *current-tab-number* curr))
		    (dashboard:summary db)
		    runs-view
		    (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! tabs "TABTITLE2" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE3" "Run Control")

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

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

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

(define (dashboard:run-update x)

 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
	  (lambda (x)
	    (on-exit (lambda ()
		       (if *db* (sqlite3:finalize! *db*))))
	    (examine-run *db* runid)))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test")
  (let ((testid (string->number (args:get-arg "-test"))))
    (if (and (number? testid)
	     (>= testid 0))
	(examine-test testid)
	(begin
	  (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor *db*))
 (else
  (set! uidat (make-dashboard-buttons *db* *num-runs* *num-tests* *dbkeys*))
  (iup:callback-set! *tim*
		     "ACTION_CB"
		     (lambda (x)
		       (let ((update-is-running #f))
			 (mutex-lock! *update-mutex*)
			 (set! update-is-running *update-is-running*)
			 (if (not update-is-running)
			     (set! *update-is-running* #t))
			 (mutex-unlock! *update-mutex*)
			 (if (not update-is-running)
			   (begin
			     (dashboard:run-update x)
			     (mutex-lock! *update-mutex*)
			     (set! *update-is-running* #f)
			     (mutex-unlock! *update-mutex*))))
		       1))))

(iup:main-loop)
(sqlite3:finalize! *db*)

;;======================================================================
;; Database access
;;======================================================================

(require-extension (srfi 18) extras tcp) ;;  rpc)
;; (import (prefix rpc rpc:))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

;; Note, try to remove this dependency 
;; (use zmq)

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

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

;; timestamp type (val1 val2 ...)
;; type: meta-info, step
(define *incoming-writes*      '())
(define *completed-writes*   (make-hash-table))
(define *incoming-last-time* (current-seconds))
(define *incoming-mutex*     (make-mutex))
(define *completed-mutex*    (make-mutex))

(define (db:get-db dbstruct run-id)
  (let ((db (if run-id
		(hash-table-ref/default (vector-ref dbstruct 1) run-id #f)
		(vector-ref dbstruct 0))))
    (if db
	db
	(let ((db (open-db run-id)))
	  (if run-id
	      (hash-table-set! (vector-ref dbstruct 1) run-id db)
	      (vector-set! dbstruct 0 db))
	  db))))
	  
(define (db:set-sync db)
  (let* ((syncval  (config-lookup *configdat* "setup"     "synchronous"))
	 (val      (cond   ;; 0 | OFF | 1 | NORMAL | 2 | FULL;
		    ((not syncval) #f)
		    ((string->number syncval)
		     (let ((val (string->number syncval)))
		       (if (member val '(0 1 2)) val #f)))
		    ((string-match (regexp "yes" #t) syncval) 1)
		    ((string-match (regexp "no"  #t) syncval) 0)
		    ((string-match (regexp "(off|normal|full)" #t) syncval) syncval)
		    (else 
		     (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval)
		     #f))))
    (if val
	(begin
	  (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val)
	  (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))

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

(define (db:get-filedb dbstruct)
  (let ((db (vector-ref dbstruct 2)))
    (if db
	db
	(let ((fdb (filedb:open-db (conc *toplevel* "/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)))
    (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)))

;;======================================================================
;; U S E   F I L E   D B   T O   S T O R E   S T R I N G S 
;;
;; N O T E ! !   T H I S   C L O B B E R S   M U L T I P L E  ////  T O  /
;;
;; Replace with something proper!
;;
;;======================================================================

;; Use to save a stored string, pad with _ to deal with trimming the prepending of /
;; 
(define (db:save-string dbstruct str)
  (let ((fdb (db:get-filedb dbstruct)))
    (filedb:register-path fdb (conc "_" str))))

;; Use to get a stored string
;;
(define (db:get-string dbstruct id)
  (let ((fdb (db:get-filedb dbstruct)))
    (string-drop (filedb:get-path fdb id) 2)))

;; This routine creates the db. It is only called if the db is not already opened
;;
(define (open-db dbstruct run-id) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
	    (exit))))
  (let* ((dbpath       (if run-id 
			   (conc *toppath* "/db/" run-id ".db")
			   (let ((dbdir (conc *toppath* "/db"))) ;; use this opportunity to create our db dir
			     (if (not (directory-exists? dbdir))
				 (create-direcory dbdir))
			     (conc *toppath* "/megatest.db"))))
	 (dbexists     (file-exists? dbpath))
	 (db           (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (write-access (file-write-access? dbpath))

	 (handler      (make-busy-timeout (if (args:get-arg "-override-timeout")
					      (string->number (args:get-arg "-override-timeout"))
					      136000)))) ;; 136000))) ;; 136000 = 2.2 minutes
    (if (and dbexists
	     (not write-access))
	(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
    (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv))
    (if write-access (sqlite3:set-busy-handler! db handler))
    (if (not dbexists)
	(if (not run-id) ;; do the megatest.db
	    (db:initialize-megatest-db db)
	    (db:initialize-run-id-db   db run-id)))
    (sqlite3:execute db "PRAGMA synchronous = 0;")
    db))

;; close all opened run-id dbs
(define (db:close-all-db)
  (for-each
   (lambda (db)
     (finalize! db))
   (hash-table-values (vector-ref *open-dbs* 1)))
  (finalize! (vector-ref *open-dbs* 0)))

(define (open-in-mem-db)
  (let* ((path   (configf:lookup *configdat* "setup" "tmpdb"))
	 (fname  (if path (conc path "/temp-megatest.db") #f))
	 (exists (and path (file-exists? fname)))
	 (db     (if path
		     (begin
		       (create-directory path #t)
		       (sqlite3:open-database fname))
		     (sqlite3:open-database ":memory:")))
	 (handler   (make-busy-timeout 3600)))
    (if (or (not path)
	    (not exists))
	(db:initialize db))
    (sqlite3:set-busy-handler! db handler)
    db))

;; (define (db:sync-table tblname fields fromdb todb)

(define (db:tbls db)
  (let ((keys  (db:get-keys db)))
    (list
     (list "keys"
	   '("id"        #f)
	   '("fieldname" #f)
	   '("fieldtype" #f))
     (list "metadat" '("var" #f) '("val" #f))
     (append (list "runs" 
		   '("id"  #f))
	     (map (lambda (k)(list k #f))
		  (append keys
			  (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))))
     (list "tests" 
	   '("id"             #f)
	   '("run_id"         #f)
	   '("testname"       #f)
	   '("host"           #f)
	   '("cpuload"        #f)
	   '("diskfree"       #f)
	   '("uname"          #f)
	   '("rundir"         #f)
	   '("shortdir"       #f)
	   '("item_path"      #f)
	   '("state"          #f)
	   '("status"         #f)
	   '("attemptnum"     #f)
	   '("final_logf"     #f)
	   '("logdat"         #f)
	   '("run_duration"   #f)
	   '("comment"        #f)
	   '("event_time"     #f)
	   '("fail_count"     #f)
	   '("pass_count"     #f)
	   '("archived"       #f))
     (list "test_steps"
	   '("id"             #f)
	   '("test_id"        #f)
	   '("stepname"       #f)
	   '("state"          #f)
	   '("status"         #f)
	   '("event_time"     #f)
	   '("comment"        #f)
	   '("logfile"        #f))
     (list "test_meta"
	   '("id"             #f)
	   '("testname"       #f)
	   '("owner"          #f)
	   '("description"    #f)
	   '("reviewed"       #f)
	   '("iterated"       #f)
	   '("avg_runtime"    #f)
	   '("avg_disk"       #f)
	   '("tags"           #f)
	   '("jobgroup"       #f)))))
    
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
(define (db:sync-tables tbls fromdb todb)
  (let ((stmts       (make-hash-table)) ;; table-field => stmt
	(all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	(numrecs     (make-hash-table))
	(start-time  (current-milliseconds)))
    (for-each ;; table
     (lambda (tabledat)
       (let* ((tablename  (car tabledat))
	      (fields     (cdr tabledat))
	      (num-fields (length fields))
	      (field->num (make-hash-table))
	      (num->field (apply vector (map car fields)))
	      (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    '())
	      (todat      (make-hash-table))
	      (count      0))

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

	 ;; read the source table
	 (sqlite3:for-each-row
	  (lambda (a . b)
	    (set! fromdat (cons (apply vector a b) fromdat)))
	  fromdb
	  full-sel)

	 ;; read the target table
	 (sqlite3:for-each-row
	  (lambda (a . b)
	    (hash-table-set! todat a (apply vector a b)))
	  todb
	  full-sel)

	 ;; first pass implementation, just insert all changed rows
	 (let ((stmth (sqlite3:prepare todb full-ins)))
	   (sqlite3:with-transaction
	    todb
	    (lambda ()
	      (for-each ;; 
	       (lambda (fromrow)
		 (let* ((a    (vector-ref fromrow 0))
			(curr (hash-table-ref/default todat a #f))
			(same #t))
		   (let loop ((i 0))
		     (if (or (not curr)
			     (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
			 (set! same #f))
		     (if (and same
			      (< i (- num-fields 1)))
			 (loop (+ i 1))))
		   (if (not same)
		       (begin
			 (apply sqlite3:execute stmth (vector->list fromrow))
			 (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
	       fromdat)))
	   (sqlite3:finalize! stmth))))
     tbls)
    (let ((runtime (- (current-milliseconds) start-time)))
      (debug:print 0 "INFO: db sync, total run time " runtime " ms")
      (for-each 
       (lambda (dat)
	 (let ((tblname (car dat))
	       (count   (cdr dat)))
	   (if (> count 0)
	       (debug:print 0 (format #f "    ~10a ~5a" tblname count)))))
       (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))))

;; (define (db:sync-to fromdb todb)
;;   ;; strategy
;;   ;;  1. Get all run-ids
;;   ;;  2. For each run-id 
;;   ;;     a. Sync that run in a transaction
;;   (let ((trecchgd    0)
;; 	(rrecchgd    0)
;; 	(tmrecchgd   0))
;; 
;;     ;; First sync test_meta data
;;     (let ((tmgetstmt (sqlite3:prepare todb "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE id=?;"))
;; 	  (tmputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO test_meta (id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup) 
;;                                                                       VALUES (?, ?,       ?,     ?,    ?,          ?,       ?,       ?,          ?,       ?,   ?);"))
;; 	  (tmdats    (db:testmeta-get-all fromdb)))
;;       ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id)
;;       (for-each
;;        (lambda (tmdat) ;; iterate over tests
;; 	 (let ((testm-id (vector-ref tmdat 0)))
;; 	   (sqlite3:with-transaction
;; 	    todb
;; 	    (lambda ()
;; 	      (let ((curr-tmdat #f))
;; 		(sqlite3:for-each-row
;; 		 (lambda (a . b)
;; 		   (set! curr-tmdat (apply vector a b)))
;; 		 tmgetstmt testm-id)
;; 		(if (not (equal? curr-tmdat tmdat)) ;; something changed
;; 		    (begin
;; 		      (debug:print 0 "  test-id: " testm-id
;; 				   "\ncurr-tdat: " curr-tmdat
;; 				   "\n     tdat: " tmdat)
;; 		      (apply sqlite3:execute tmputstmt (vector->list tmdat))
;; 		      (set! tmrecchgd (+ tmrecchgd 1)))))))))
;;        tmdats)
;;       (sqlite3:finalize! tmgetstmt)
;;       (sqlite3:finalize! tmputstmt))
;; 
;;     ;; First sync tests data
;;     (let ((run-ids     (db:get-all-run-ids fromdb))
;; 	  (tgetstmt    (sqlite3:prepare todb "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;"))
;; 	  (tputstmt    (sqlite3:prepare todb "INSERT OR REPLACE INTO tests  (id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment)
;;                                                                     VALUES (?, ?,     ?,       ?,    ?,     ?,         ?,   ?,      ?,       ?,    ?,     ?,        ?,           ?,         ?     );")))
;;       (for-each
;;        (lambda (run-id)
;; 	 (let ((tdats     (db:get-all-tests-info-by-run-id fromdb run-id)))
;; 	   ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id)
;; 	   (for-each
;; 	    (lambda (tdat) ;; iterate over tests
;; 	      (let ((test-id (vector-ref tdat 0)))
;; 		(sqlite3:with-transaction
;; 		 todb
;; 		 (lambda ()
;; 		   (let ((curr-tdat #f))
;; 		     (sqlite3:for-each-row
;; 		      (lambda (a . b)
;; 			(set! curr-tdat (apply vector a b)))
;; 		      tgetstmt
;; 		      test-id)
;; 		     (if (not (equal? curr-tdat tdat)) ;; something changed
;; 			 (begin
;; 			   (debug:print 0 "  test-id: " test-id
;; 					"\ncurr-tdat: " curr-tdat
;; 					"\n     tdat: " tdat)
;; 			   (apply sqlite3:execute tputstmt (vector->list tdat))
;; 			   (set! trecchgd (+ trecchgd 1)))))))))
;; 	    tdats)))
;;        run-ids)
;;       (sqlite3:finalize! tgetstmt)
;;       (sqlite3:finalize! tputstmt))
;; 
;;     ;; Next sync runs table
;;     (let* ((rdats       '())
;; 	   (keys        (db:get-keys fromdb))
;; 	   (rstdfields  (conc "id," (string-intersperse keys ",") ",runname,state,status,owner,event_time,comment,fail_count,pass_count"))
;; 	   (rnumfields  (length (string-split rstdfields ",")))
;; 	   (runslots    (string-intersperse (make-list rnumfields "?") ","))
;; 	   (rgetstmt    (sqlite3:prepare todb (conc "SELECT " rstdfields " FROM runs WHERE id=?;")))
;; 	   (rputstmt    (sqlite3:prepare todb (conc "INSERT OR REPLACE INTO runs (" rstdfields ") VALUES ( " runslots " );"))))
;;       ;; first collect all the source run data
;;       (sqlite3:for-each-row
;;        (lambda (a . b)
;; 	 (set! rdats (cons (apply vector a b) rdats)))
;;        fromdb
;;        (conc "SELECT " rstdfields " FROM runs;"))
;;       (sqlite3:with-transaction
;;        todb
;;        (lambda ()
;; 	 (for-each 
;; 	  (lambda (rdat)
;; 	    (let ((run-id    (vector-ref rdat 0))
;; 		  (curr-rdat #f))
;; 	      ;; first get the current value of the equivalent row from the target
;; 	      ;; read, then insert/overwrite if different
;; 	      (sqlite3:for-each-row 
;; 	       (lambda (a . b)
;; 		 (set! curr-rdat (apply vector a b)))
;; 	       rgetstmt
;; 	       run-id)
;; 	      (if (not (equal? curr-rdat rdat))
;; 		  (begin
;; 		    (debug:print 0 "   run-id: " run-id
;; 				 "\ncurr-rdat: " curr-rdat
;; 				 "\n     rdat: " rdat)
;; 		    (set! rrecchgd (+ rrecchgd 1))
;; 		    (apply sqlite3:execute rputstmt (vector->list rdat))))))
;; 	  rdats)))
;;       (sqlite3:finalize! rgetstmt)
;;       (sqlite3:finalize! rputstmt))
;; 
;;     (if (> rrecchgd 0)  (debug:print 0 "synced " rrecchgd " changed records in runs  table"))
;;     (if (> trecchgd 0)  (debug:print 0 "synced " trecchgd " changed records in tests table"))
;;     (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table"))
;;     (+ rrecchgd trecchgd tmrecchgd)))

(define (db:sync-back)
  (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*))

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

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

;; (define open-run-close 
(define open-run-close (if (debug:debug-mode 2)




			   open-run-close-no-exception-handling















			   open-run-close-exception-handling))


(define (db:initialize-megatest-db db)

  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:configq-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys)))
    (for-each (lambda (key)
		(let ((keyn key))
		  (if (member (string-downcase keyn)
			      (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
				    "pass_count"))
		      (begin
			(print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table")
			(system (conc "rm -f " dbpath))
			(exit 1)))))
	      keys)


    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
    (for-each (lambda (key)
		(sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
	      keys)
    (sqlite3:execute db (conc 
			 "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " 
			 fieldstr (if havekeys "," "")
			 "runname    TEXT DEFAULT 'norun',"
			 "state      TEXT DEFAULT '',"
			 "status     TEXT DEFAULT '',"
			 "owner      TEXT DEFAULT '',"
			 "event_time TIMESTAMP DEFAULT (strftime('%s','now')),"
			 "comment    TEXT DEFAULT '',"
			 "fail_count INTEGER DEFAULT 0,"
			 "pass_count INTEGER DEFAULT 0,"
			 "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))




























    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
                                     id          INTEGER PRIMARY KEY,













                                     testname    TEXT DEFAULT '',
                                     author      TEXT DEFAULT '',
                                     owner       TEXT DEFAULT '',
                                     description TEXT DEFAULT '',
                                     reviewed    TIMESTAMP,
                                     iterated    TEXT DEFAULT '',
                                     avg_runtime REAL,
                                     avg_disk    REAL,
                                     tags        TEXT DEFAULT '',
                                     jobgroup    TEXT DEFAULT 'default',
                                CONSTRAINT test_meta_constraint UNIQUE (testname));")
    (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
    ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,










                                  CONSTRAINT metadat_constraint UNIQUE (var));")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
    ;; Must do this *after* running patch db !! No more. 
    (db:set-var db "MEGATEST_VERSION" megatest-version)
    (debug:print-info 11 "db:initialize END")))


;;======================================================================
;; R U N   S P E C I F I C   D B 
;;======================================================================




















(define (db:initialized-run-id-db db run-id)

  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests 
                              (id           INTEGER   PRIMARY KEY,
                     run_id       INTEGER   DEFAULT -1,
                     testname     TEXT      DEFAULT 'noname',
                     host         TEXT      DEFAULT 'n/a',
                     cpuload      REAL      DEFAULT -1,
                     diskfree     INTEGER   DEFAULT -1,
                     uname        TEXT      DEFAULT 'n/a', 
                     rundir       TEXT      DEFAULT 'n/a',
                     shortdir     TEXT      DEFAULT '',
                     item_path    TEXT      DEFAULT '',
                     state        TEXT      DEFAULT 'NOT_STARTED',

                     status       TEXT      DEFAULT 'FAIL',
                     attemptnum   INTEGER   DEFAULT 0,
                     final_logf   TEXT      DEFAULT 'logs/final.log',
                     logdat       TEXT      DEFAULT '', 
                     run_duration INTEGER   DEFAULT 0,
                     comment      TEXT      DEFAULT '',
                     event_time   TIMESTAMP DEFAULT (strftime('%s','now')),
                     fail_count   INTEGER   DEFAULT 0,
                     pass_count   INTEGER   DEFAULT 0,
                     archived     INTEGER   DEFAULT 0, -- 0=no, 1=in progress, 2=yes
                        CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
  (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);")
  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps 




                              (id          INTEGER PRIMARY KEY,


                               test_id     INTEGER, 
                               stepname    TEXT, 
                               state       TEXT DEFAULT 'NOT_STARTED', 
                               status      TEXT DEFAULT 'n/a',
                               event_time  TIMESTAMP,
                               comment     TEXT DEFAULT '',
                               logfile     TEXT DEFAULT '',
                        CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")


  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data 

                              (id          INTEGER PRIMARY KEY,
                                     reviewed    TIMESTAMP DEFAULT (strftime('%s','now')),
                                     avg_runtime REAL DEFAULT -1,
                                     avg_disk    REAL DEFAULT -1,




                               test_id     INTEGER,
                               category    TEXT DEFAULT '',
                               variable    TEXT,


	                       value       REAL,
	                       expected    REAL,
	                       tol         REAL,
                               units       TEXT,
                               comment     TEXT DEFAULT '',
                               status      TEXT DEFAULT 'n/a',
                               type        TEXT DEFAULT '',
                        CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
                              id           INTEGER PRIMARY KEY,
                              test_id      INTEGER,



                              update_time  TIMESTAMP,
                              cpuload      INTEGER DEFAULT -1,
                              diskfree     INTEGER DEFAULT -1,





                              diskusage    INTGER DEFAULT -1,


                              run_duration INTEGER DEFAULT 0);")


  db)

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

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

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



    (db:log-event logline)))

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

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

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

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


(define (db:find-and-mark-incomplete db #!key (ovr-deadtime #f))


  (let* ((incompleted '())

	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200)) ;; two hours
	 (run-ids      (db:get-run-ids db))) ;; iterate over runs to divy up the calls
    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
    (for-each

     (lambda (run-id)


       ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes

       ;;
       ;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns.
       ;;                   The testdat.db file must be consulted.
       ;;
       ;; HOWEVER: this code in run:test seems to work fine
       ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)








       ;;                     (db:test-get-run_duration testdat)))
       ;;                    600) 
       (sqlite3:for-each-row 
	(lambda (test-id)
	  (set! incompleted (cons test-id incompleted)))
	db
	"SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('RUNNING','REMOTEHOSTSTART');"
	run-id deadtime)

       ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config

       ;;





       (sqlite3:for-each-row

	(lambda (test-id)



	  (set! incompleted (cons test-id incompleted)))

	db
	"SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('LAUNCHED');"
	run-id (* 60 60 24)))
     run-ids)
       



    ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
    ;;
    (if (> (length incompleted) 0)
	(begin


	  (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc incompleted) ", ") " as INCOMPLETE")
	  (sqlite3:execute 
	   db



	   (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" 







		 (string-intersperse (map conc incompleted) ",")
		 ");"))))))
		     
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
(define (db:clean-up dbstruct)

  (debug:print 0 "ERROR: db clean up not ported yet")

  (let* ((db         (db:get-db dbstruct #f))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
	 (statements
	  (map (lambda (stmt)
		 (sqlite3:prepare db stmt))
	       (list
		;; delete all tests that belong to runs that are 'deleted'
		"DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');"
		;; delete all tests that are 'DELETED'
		"DELETE FROM tests WHERE state='DELETED';"
		;; delete all tests that have no run
		"DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);"
		;; delete all runs that are state='deleted'
		"DELETE FROM runs WHERE state='deleted';"
		;; delete empty runs
		"DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);"
	       ))))
    (sqlite3:with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count before clean: " tot))
			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    (db:find-and-mark-incomplete db)
    (sqlite3:execute db "VACUUM;")))




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

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

  (let* ((start-ms (current-milliseconds))
         (throttle (let ((t  (config-lookup *configdat* "setup" "throttle")))
		     (if t (string->number t) t)))
	 (res      #f))
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     (db:get-db dbstruct #f)
     "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)

  (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))


(define (db:del-var dbstruct var)

  (sqlite3:execute (db:get-db dbstruct #f) "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*
;; using keys:config-get-fields?

(define (db:get-keys dbstruct)
  (if *db-keys* *db-keys* 
      (let ((res '()))
	(sqlite3:for-each-row 
	 (lambda (key)
	   (set! res (cons key res)))
	 (db:get-db dbstruct #f)
	 "SELECT fieldname FROM keys ORDER BY id DESC;")
	(set! *db-keys* res)
	res)))

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

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

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

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

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

			     (if (null? patts)
				 '("")
				 patts))
			comparator)))


;; register a test run with the db
(define (db:register-run dbstruct keyvals runname state status user)
  (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user)
  (let* ((db        (db:get-db dbstruct #f))
	 (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 ")))

		 qryvals)
	  (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
	  res) 
	(begin
	  (debug:print 0 "ERROR: Called without all necessary keys")
	  #f))))

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

;; 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)
  (let* ((db         (db:get-db dbstruct #f))
	 (res       '())
	 (keys       (db:get-keys dbstruct))
	 (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' ..."

     qrystr
     )
    (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
    (vector header res)))

;; Get all targets from the db
;;
(define (db:get-targets dbstruct)
  (let* ((res       '())
	 (keys       (db:get-keys dbstruct))
	 (header     keys) ;; (map key:get-fieldname keys))
	 (keystr     (keys->keystr keys))
	 (qrystr     (conc "SELECT " keystr " FROM runs;"))
	 (seen       (make-hash-table)))
    (sqlite3:for-each-row
     (lambda (a . x)
       (let ((targ (cons a x)))
	 (if (not (hash-table-ref/default seen targ #f))
	     (begin
	       (hash-table-set! seen targ #t)
	       (set! res (cons (apply vector targ) res))))))
     (db:get-db dbstruct #f)
     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)
  (let ((numruns 0))
    (debug:print-info 11 "db:get-num-runs START " runpatt)
    (sqlite3:for-each-row 
     (lambda (count)
       (set! numruns count))
     (db:get-db dbstruct #f)
     "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
    (debug:print-info 11 "db:get-num-runs END " runpatt)
    numruns))

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

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

;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
(define (db:get-run-info dbstruct run-id)
  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
  ;;    (hash-table-ref *run-info-cache* run-id)
  (let* ((res       (vector #f #f #f #f))
	 (keys      (db:get-keys dbstruct))
	 (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
	 (header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    (sqlite3:for-each-row
     (lambda (a . x)
       (set! res (apply vector a x)))
     (db:get-db dbstruct #f)
     (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)

  (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET comment=? WHERE id=?;" comment run-id))


;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run dbstruct run-id)

  ;; First set any related tests to DELETED
  (let ((db (db:get-db dbstruct run-id)))
    (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='';")



    (sqlite3:execute db "DELETE FROM test_steps;")
    (sqlite3:execute db "DELETE FROM test_data;")


    (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))

(define (db:update-run-event_time dbstruct run-id)

  (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))


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

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

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

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

;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
(define (db:get-key-val-pairs dbstruct run-id)
  (let* ((keys (db:get-keys dbstruct))
	 (res  '()))

    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
	 ;; (debug:print 0 "qry: " qry)
	 (sqlite3:for-each-row 
	  (lambda (key-val)
	    (set! res (cons (list key key-val) res)))
	  (db:get-db dbstruct #f) qry run-id)))
     keys)

    (reverse res)))

;; get key vals for a given run-id
(define (db:get-key-vals dbstruct run-id)
  (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f)))
     (if mykeyvals 
	 mykeyvals
	(let* ((keys (db:get-keys dbstruct))
	       (res  '()))

	  (for-each 
	   (lambda (key)
	     (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))

	       (sqlite3:for-each-row 
		(lambda (key-val)
		  (set! res (cons key-val res)))
		(db:get-db dbstruct #f) 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 ((mytarg (hash-table-ref/default *target* run-id #f)))
    (if mytarg
	mytarg
	(let* ((keyvals (db:get-key-vals dbstruct run-id))
	       (thekey  (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
	  (hash-table-set! *target* run-id thekey)
	  thekey))))

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

  (let* ((qryvalstr       (case qryvals

			    ((shortlist) "id,run_id,testname,item_path,state,status")
			    ((#f)        "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
			    (else        qryvals)))
	 (res            '())
	 ;; if states or statuses are null then assume match all when not-in is false
	 (states-qry      (if (null? states) 
			      #f
			      (conc " state "  
				    (if not-in
					" NOT IN ('"

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

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


(define (db:get-tests-for-run-state-status db run-id testpatt)
  (let* ((res            '())
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (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)
    (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 db test-id)

  (let ((res            #f))









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


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

;; ;; ;; 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 status not-in)
;; ;;   (db:get-tests-for-runs dbstruct run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))
;; ;; 
;; ;; ;; NB // This is get tests for "runs" (note the plural!!)
;; ;; ;;
;; ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN



;; ;; ;; i.e. these lists define what to NOT show.
;; ;; ;; states and statuses are required to be lists, empty is ok
;; ;; ;; not-in #t = above behaviour, #f = must match






;; ;; ;; run-ids is a list of run-ids or a single number or #f for all runs





;; ;; (define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses 
;; ;; 			       #!key (not-in #t)
;; ;; 			       (sort-by #f)
;; ;; 			       (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time
;; ;;   (let* ((res '())
;; ;; 	 ;; if states or statuses are null then assume match all when not-in is false
;; ;; 	 (states-qry      (if (null? states) 

;; ;; 			      #f
;; ;; 			      (conc " state "  
;; ;; 				    (if not-in "NOT" "") 
;; ;; 				    " IN ('" 
;; ;; 				    (string-intersperse states   "','")
;; ;; 				    "')")))





;; ;; 	 (statuses-qry    (if (null? statuses)


;; ;; 			      #f
;; ;; 			      (conc " status "
;; ;; 				    (if not-in "NOT" "") 
;; ;; 				    " IN ('" 
;; ;; 				    (string-intersperse statuses "','")
;; ;; 				    "')")))
;; ;; 	 (tests-match-qry (tests:match->sqlqry testpatt))
;; ;; 	 (qry             (conc "SELECT " qryvals 
;; ;; 				" FROM tests WHERE state != 'DELETED' "
;; ;; 				(if run-ids


;; ;; 				    (if (list? run-ids)
;; ;; 					(conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ")
;; ;; 					(conc "AND run_id=" run-ids " "))
;; ;; 				    " ") ;; #f => run-ids don't filter on run-ids
;; ;; 				(if states-qry   (conc " AND " states-qry)   "")
;; ;; 				(if statuses-qry (conc " AND " statuses-qry) "")
;; ;; 				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
;; ;; 				(case sort-by
;; ;; 				  ((rundir)     " ORDER BY length(rundir) DESC;")
;; ;; 				  ((event_time) " ORDER BY event_time ASC;")
;; ;; 				  (else         ";"))
;; ;; 				)))
;; ;;     (debug:print-info 8 "db:get-tests-for-runs qry=" qry)
;; ;;     (sqlite3:for-each-row 
;; ;;      (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
;; ;;        (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
;; ;;      db 
;; ;;      qry
;; ;;      )
;; ;;     res))


(define (db:delete-test-records dbstruct run-id test-id)






;; (define (db:delete-test-step-records dbstruct run-id test-id)
  (let ((db (db:get-db dbstruct run-id)))





  (db:general-call db 'delete-test-step-records (list test-id))
  (db:general-call db '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-tests-for-run dbstruct run-id)

  (let ((db (db:get-db dbstruct run-id)))
    (sqlite3:execute db "DELETE FROM tests;")))

(define (db:delete-old-deleted-test-records dbstruct)

  (let ((run-ids  (db:get-all-run-ids dbstruct))
	(targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
    (for-each
     (lambda (run-id)
       (sqlite3:execute (db:get-db dbstruct run-id) "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
;;
(define (db:set-tests-state-status dbstruct 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 ") "")
			       " testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
		;;(debug:print 0 "QRY: " qry)
		(sqlite3:execute (db:get-db dbstruct run-id) qry run-id newstate newstatus testname 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)
  (let ((db (db:get-db dbstruct run-id)))
    (cond
     ((and newstate newstatus newcomment)
      (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id))
     ((and newstate newstatus)
      (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
     (else
      (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
      (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
      (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))
  (db:process-triggers test-id newstate newstatus)
  #t)) ;; retrun something to keep the remote calls happy

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

;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-running dbstruct run-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     (db:get-db dbstruct run-id)
     "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');")
    res))

;; 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)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND id=?;" run-id)
    res))


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

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

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining dbstruct run-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     (db:get-db dbstruct run-id) ;; NB// KILLREQ means the jobs is still probably running
     "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ');")
    res))

;; map run-id, testname item-path to test-id











(define (db:get-test-id-not dbstruct run-id testname item-path)





  (let* ((res #f))
    (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 )
       (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )))
     (db:get-db dbstruct run-id)
     "SELECT id FROM tests WHERE testname=? AND item_path=?;"
     testname item-path)
    res))


(define db:test-record-qry-selector "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir_id,item_path,run_duration,final_logf,comment,realdir_id")











































;; NOTE: Use db:test-get* to access records
















;; NOTE: This needs rundir_id 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)




  (let ((res '()))
    (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)
       ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
       (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
		       res)))
     (db:get-db dbstruct run-id)
     (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE run_id=?;")
     run-id)
    res))

;; Get test data using test_id
(define (db:get-test-info-by-id dbstruct run-id test-id)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id)
       ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
       (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id)))
     (db:get-db dbstruct run-id)
     (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)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id)
       ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
       (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id)
		       res)))
     (db:get-db dbstruct run-id) 
     (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)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (a . b)
       (set! res (apply vector a b)))
     (db:get-db dbstruct run-id)
     (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)
  (let ((res #f))



    (sqlite3:for-each-row
     (lambda (tpath)
       (set! res tpath))
     (db:get-db dbstruct run-id)
     "SELECT rundir FROM tests WHERE id=?;"
     test-id)
    res))

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

(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile)
   (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 db test-id)
  (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 db test-id)
  (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)))

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

;; 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 db test-id status)
  (let ((fail-count 0)
	(pass-count 0))
    (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 db '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 db 'test_data-pf-rollup (list test-id test-id test-id test-id))))

(define (db:csv->test-data db test-id csvdata)
  (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
  (let ((csvlist (csv->list (make-csv-reader
			     (open-input-string csvdata)
			     '((strip-leading-whitespace? #t)
			       (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata)))
    (for-each 
     (lambda (csvrow)
       (let* ((padded-row  (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
	      (category    (list-ref padded-row 0))
	      (variable    (list-ref padded-row 1))
	      (value       (any->number-if-possible (list-ref padded-row 2)))
	      (expected    (any->number-if-possible (list-ref padded-row 3)))
	      (tol         (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
	      (units       (list-ref padded-row 5))
	      (comment     (list-ref padded-row 6))
	      (status      (let ((s (list-ref padded-row 7)))
			     (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
						     (string-match (regexp "^n/a$") s)))
				 #f
				 s))) ;; if specified on the input then use, else calculate
	      (type        (list-ref padded-row 8)))
	 ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
	 (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value 
		      ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
	 
	 (if (and (or (not expected)(equal? expected ""))
		  (or (not tol)     (equal? expected ""))
		  (or (not units)   (equal? expected "")))
	     (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test tdb test-id category variable)))
			 (set! expected new-expected)
			 (set! tol      new-tol)
			 (set! units    new-units)))
	 
	 (debug:print 4 "AFTER:  category: " category " variable: " variable " value: " value 
		      ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
	 ;; calculate status if NOT specified
	 (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
	     (if (number? tol) ;; if tol is a number then we do the standard comparison
		 (let* ((max-val (+ expected tol))
			(min-val (- expected tol))
			(result  (and (>=  value min-val)(<= value max-val))))
		   (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result)
		   (set! status (if result "pass" "fail")))
		 (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
		       (case (string->symbol tol) ;; tol should be >, <, >=, <=
			 ((>)  (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)
	 (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
;;======================================================================

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

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

(define (db:test-get-paths-matching-keynames-target-new dbstruct keynames target res testpatt statepatt statuspatt runname)





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


    res))





















;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj)
  (case *transport-type*
    ;; ((fs) obj)
    ((http fs)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode (with-output-to-string (lambda ()(serialize obj))))
      #t))
    ((zmq)(with-output-to-string (lambda ()(serialize obj))))
    (else obj)))

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

(define (db:test-set-status-state dbstruct run-id test-id status state msg)

  (let ((db  (db:get-db dbstruct rid)))


    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))

























	(db:general-call db 'set-test-start-time (list test-id)))
    (if msg





	(db:general-call db 'state-status-msg (list state status msg test-id))
	(db:general-call db 'state-status     (list state status test-id)))))



















































(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)


  (if (and (not (equal? item-path ""))


	   (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))


      (let ((db (db:get-db dbstruct rid)))


	(handle-exceptions




	 exn
	 (begin 


	   (debug:print 0 "Problem with call to cdb:remote-run, database may be locked and read-only, waiting and trying again ...")


	   (thread-sleep! 10)

	   (apply cdb:remote-run proc db params))
	 (apply cdb:remote-run proc db params)))))




(define (db:tests-register-test dbstruct run-id test-name item-path)



  (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path))





























(define (db:test-get-logfile-info dbstruct run-id test-name)
  (let ((res #f))
    (sqlite3:for-each-row 
     (lambda (path-id final_logf-id)
       (let ((path       (db:get-path   dbstruct path-id))
	     (final_logf (db:get-string dbstruct final_logf-id)))
	 (set! logf final_logf)
	 (set! res (list path final_logf))
	 (if (directory? path)
	     (debug:print 2 "Found path: " path)
	     (debug:print 2 "No such path: " path))))
     (db:get-db dbstruct run-id)
     "SELECT rundir_id,final_logf_id FROM tests WHERE testname=? AND item_path='';"
     test-name)
    res))

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

(define db:queries 
  (list '(update-run-duration     "UPDATE tests SET run_duration=? WHERE id=?;")

	;; TESTS
	'(register-test          "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
	;; Test state and status
	'(set-test-state         "UPDATE tests SET state=?   WHERE id=?;")
	'(set-test-status        "UPDATE tests SET state=?   WHERE id=?;")
	'(state-status           "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE
	'(state-status-msg       "UPDATE tests SET state=?,status=?,comment_id=? WHERE id=?;") ;; DONE
	;; Test comment
	'(set-test-comment       "UPDATE tests SET comment_id=? WHERE id=?;")
	'(set-test-start-time    "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
	'(pass-fail-counts       "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
	;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
	'(test_data-pf-rollup    "UPDATE tests
                                    SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
                                      THEN 'FAIL'
                                    WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
                                      (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
                                    THEN 'PASS'
                                    ELSE status
                                    END WHERE id=?;") ;; DONE
	'(test-set-log            "UPDATE tests SET final_logf_id=? WHERE id=?;")      ;; DONE
	'(test-set-rundir-by-test-id "UPDATE tests SET rundir_id=? WHERE id=?")        ;; DONE
	'(test-set-rundir         "UPDATE tests SET rundir_id=? AND testname=? AND item_path=?;") ;; DONE
	'(delete-tests-in-state   "DELETE FROM tests WHERE state=?;")                  ;; DONE
	'(tests:test-set-toplog   "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
	'(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE

	'(update-uname-host       "UPDATE tests SET uname=?,host=? WHERE id=?;")       ;; DONE
	'(update-test-state       "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
	'(update-test-status      "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
	;; stuff for roll-up-pass-fail-counts
	'(update-pass-fail-counts "UPDATE tests 
             SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')),
                 pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
             WHERE testname=? AND item_path='';") ;; DONE
	'(top-test-set-running  "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE
	'(top-test-set-per-pf-counts "UPDATE tests
                       SET state=CASE 
                                   WHEN (SELECT count(id) FROM tests 
                                                WHERE testname=?
                                                     AND item_path != '' 
                                                     AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
                                   ELSE 'COMPLETED' END,
                            status=CASE 
                                  WHEN fail_count > 0 THEN 'FAIL' 
                                  WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' 
                                  WHEN (SELECT count(id) FROM tests
                                         WHERE testname=?
                                              AND item_path != ''
                                              AND status = 'SKIP') > 0 THEN 'SKIP'
                                  ELSE 'UNKNOWN' END
                       WHERE testname=? AND item_path='';") ;; DONE

	;; STEPS
	'(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE id=?;")
	'(delete-test-data-records "UPDATE test_data  SET status='DELETED' WHERE id=?;") ;; using status since no state field
	))

(define (db:lookup-query qry-name)
  (let ((q (alist-ref qry-name db:queries)))
    (if q (car q) #f)))

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

(define (db:login db calling-path calling-version client-signature)
  (if (and (equal? calling-path *toppath*)
	   (equal? megatest-version calling-version))











      (begin

	(hash-table-set! *logged-in-clients* client-signature (current-seconds))
	'(#t "successful login"))      ;; path matches - pass! Should vet the caller at this time ...
      (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))



(define (db:process-write db request-item)
  (let ((stmt-key (vector-ref request-item 0))
	(query    (vector-ref request-item 1))
	(params   (vector-ref request-item 2))
	(queryh   (sqlite3:prepare db query)))
    (apply sqlite3:execute stmt params)
    #f))
;; DISABLING FOR NOW 
;; DISABLING FOR NOW (define *number-of-writes*         0)
;; DISABLING FOR NOW (define *writes-total-delay*       0)
;; DISABLING FOR NOW (define *total-non-write-delay*    0)
;; DISABLING FOR NOW (define *number-non-write-queries* 0)
;; DISABLING FOR NOW 
;; DISABLING FOR NOW ;; The queue is a list of vectors where the zeroth slot indicates the type of query to
;; DISABLING FOR NOW ;; apply and the second slot is the time of the query and the third entry is a list of 
(define (db:general-call db stmtname params)
  (let ((query (let ((q (alist-ref (if (string? stmtname)
				       (string->symbol stmtname)
				       stmtname)
				   db:queries)))
		 (if q (car q) #f))))
    (apply sqlite3:execute db query params)


    #t))









;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;; 
;; Run this server-side
;;
(define (db:get-previous-test-run-record db run-id test-name item-path)
  (let* ((keys    (db:get-keys db))
	 (selstr  (string-intersperse  keys ","))
	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
	 (keyvals #f))
    ;; first look up the key values from the run selected by run-id
    (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)


	#f
	(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)))
	  ;; for each run starting with the most recent look to see if there is a matching test
	  ;; if found then return that matching test record
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) #f



	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (db:get-tests-for-run db 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)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))















;; 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 db run-id test-name item-path)
  (let* ((keys    (db:get-keys db))




	 (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
    (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 db 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:test-get-records-for-index-file dbstruct run-id test-name)
  (let ((res '()))
    (sqlite3:for-each-row 
     (lambda (id itempath state status run_duration logf-id comment-id)
       (let ((logf    (db:get-string dbstruct logf-id))
	     (comment (db:get-string dbstruct comment-id)))
	 (set! res (cons (vector id itempath state status run_duration logf comment) res)))
     (db:get-db dbstruct run-id)
     "SELECT id,item_path,state,status,run_duration,final_logf_id,comment_id 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)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags)
       (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags)))
     (db:get-db dbstruct #f)
     "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;"
     testname)
    res))

;; create a new record for a given testname
(define (db:testmeta-add-record dbstruct testname)
  (sqlite3:execute (db:get-db dbstruct #f) "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)
  (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))




(define (db:testmeta-get-all db)
































































  (let ((res '()))





















































































    (sqlite3:for-each-row
















     (lambda (a . b)




































       (set! res (cons (apply vector a b) res)))

     (db:get-db dbstruct run-id)












     "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")










    res))














































;; 		      (else #f)))))
;;       res)))






























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

;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met:
;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;;       mode 'toplevel means that tests must be COMPLETED only
;;       mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;; 
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
  (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 db 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))

	     ;; if the test is not found then clearly the waiton is not met...
	     ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
	     (if (not ever-seen)
		 (set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
	 waitons)
	(delete-duplicates result))))




















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

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

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

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

(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id           vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id       vec) (vector-ref vec 1))
(define-inline (db:test-get-testname     vec) (vector-ref vec 2))
(define-inline (db:test-get-state        vec) (vector-ref vec 3))
(define-inline (db:test-get-status       vec) (vector-ref vec 4))
(define-inline (db:test-get-event_time   vec) (vector-ref vec 5))
(define-inline (db:test-get-host         vec) (vector-ref vec 6))
(define-inline (db:test-get-cpuload      vec) (vector-ref vec 7))
(define-inline (db:test-get-diskfree     vec) (vector-ref vec 8))
(define-inline (db:test-get-uname        vec) (vector-ref vec 9))
(define-inline (db:test-get-rundir       vec) (vector-ref vec 10))
(define-inline (db:test-get-item-path    vec) (vector-ref vec 11))
(define-inline (db:test-get-run_duration vec) (vector-ref vec 12))
(define-inline (db:test-get-final_logf   vec) (vector-ref vec 13))
(define-inline (db:test-get-comment      vec) (vector-ref vec 14))
(define-inline (db:test-get-pass_count   vec) (vector-ref vec 15))
(define-inline (db:test-get-fail_count   vec) (vector-ref vec 16))
(define-inline (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))

(define-inline (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
(define-inline (db:test-get-first_warn   vec) (printable (vector-ref vec 16)))

(define-inline (db:test-set-cpuload!  vec val)(vector-set! vec 7 val))

;;======================================================================
;; S T E P S 
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time    
(define (make-db:step)(make-vector 7))
(define-inline (tdb:step-get-id              vec)    (vector-ref  vec 0))
(define-inline (tdb:step-get-test_id         vec)    (vector-ref  vec 1))
(define-inline (tdb:step-get-stepname        vec)    (vector-ref  vec 2))
(define-inline (tdb:step-get-state           vec)    (vector-ref  vec 3))
(define-inline (tdb:step-get-status          vec)    (vector-ref  vec 4))
(define-inline (tdb:step-get-event_time      vec)    (vector-ref  vec 5))
(define-inline (tdb:step-get-logfile         vec)    (vector-ref  vec 6))
(define-inline (tdb:step-set-id!             vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-set-test_id!        vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-set-stepname!       vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-set-state!          vec val)(vector-set! vec 3 val))
(define-inline (tdb:step-set-status!         vec val)(vector-set! vec 4 val))
(define-inline (tdb:step-set-event_time!     vec val)(vector-set! vec 5 val))
(define-inline (tdb:step-set-logfile!        vec val)(vector-set! vec 6 val))


;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define-inline (tdb:steps-table-get-stepname   vec)    (vector-ref  vec 0))
(define-inline (tdb:steps-table-get-start      vec)    (vector-ref  vec 1))
(define-inline (tdb:steps-table-get-end        vec)    (vector-ref  vec 2))
(define-inline (tdb:steps-table-get-status     vec)    (vector-ref  vec 3))
(define-inline (tdb:steps-table-get-runtime    vec)    (vector-ref  vec 4))
(define-inline (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
(define-inline (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))

;; use this one for db-get-run-info
(define-inline (db:get-row    vec)(vector-ref vec 1))

;; The data structure for handing off requests via wire
(define (make-cdb:packet)(make-vector 6))
(define-inline (cdb:packet-get-client-sig   vec)    (vector-ref  vec 0))

    (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; Megatest version
    (iup:attribute-set! general-matrix "3:0" "Version")
    (iup:attribute-set! general-matrix "3:1" megatest-version)

    general-matrix))

(define (dcommon:run-stats db)
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (db:get-run-stats db))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))

		  
		  (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t))
		  
		  ;; call the command using mt_ezstep
		  (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
		  
		  (debug:print 4 "script: " script)

		  (rmt:teststep-set-status! #f test-id stepname "start" "-" #f #f)
		  ;; now launch
		  (let ((pid (process-run script)))
		    (let processloop ((i 0))
		      (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
				  (mutex-lock! run-mutex)
				  (vector-set! exit-info 0 pid)
				  (vector-set! exit-info 1 exit-status)
				  (vector-set! exit-info 2 exit-code)
				  (mutex-unlock! run-mutex)
				  (if (eq? pid-val 0)
				      (begin
					(thread-sleep! 1)
					(processloop (+ i 1))))
				  ))
		    (let ((exinfo (vector-ref exit-info 2))
			  (logfna (if logpro-used (conc stepname ".html") "")))

		      (rmt:teststep-set-status! #f test-id stepname "end" exinfo #f logfna))
		    (if logpro-used
			(rmt:test-set-log! test-id (conc stepname ".html")))
		    ;; set the test final status
		    (let* ((this-step-status (cond
					      ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
					      ((eq? (vector-ref exit-info 2) 0)                   'pass)
					      (else 'fail)))
			   (overall-status   (cond
					      ((eq? rollup-status 2) 'warn)

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

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

;; Copyright 2006-2011, Matthew Welland.
;;
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;;
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
(import (prefix sqlite3 sqlite3:))

(declare (unit filedb))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	 ;;        	      hostn))
	 (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    (if (and (args:get-arg "-port")
				 (string->number (args:get-arg "-port")))
			    (string->number (args:get-arg "-port"))
			    (if (and (config-lookup  *configdat* "server" "port")
				     (string->number (config-lookup  *configdat* "server" "port")))
				(string->number (config-lookup  *configdat* "server" "port"))
				(+ 5000 (random 1001)))))
	 (link-tree-path (config-lookup *configdat* "setup" "linktree")))
    (set! db *inmemdb*)
    (root-path     (if link-tree-path 
		       link-tree-path
		       (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
    (handle-directory spiffy-directory-listing)
    ;; http-transport:handle-directory) ;; simple-directory-handler)
    ;; Setup the web server and a /ctrl interface
    ;;
    (vhost-map `(((* any) . ,(lambda (continue)
			       ;; open the db on the first call 
				 ;; 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 db $) ;; 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*))
				  ;; This is the /ctrl path where data is handed to the server and
				  ;; responses 
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "ctrl"))
				   (let* ((packet (db:string->obj dat))
					  (qtype  (cdb:packet-get-qtype packet)))
				     (debug:print-info 12 "server=> received packet=" packet)

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

;;======================================================================
;; C L I E N T S
;;======================================================================

(define *http-mutex* (make-mutex))
(define *http-requests-in-progress* 0)
(define *http-connections-next-cleanup* (current-seconds))

(define (http-transport:get-time-to-cleanup)
  (let ((res #f))
    (mutex-lock! *http-mutex*)
    (set! res (> (current-seconds) *http-connections-next-cleanup*))
    (mutex-unlock! *http-mutex*)
    res))

(define (http-transport:inc-requests-count)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
  ;; Use this opportunity to slow things down iff there are too many requests in flight
  (if (> *http-requests-in-progress* 5)
      (begin
	(debug:print-info 0 "Whoa there buddy, ease up...")
	(thread-sleep! 1)))
  (mutex-unlock! *http-mutex*))

(define (http-transport:dec-requests-count proc) 
  (mutex-lock! *http-mutex*)
  (proc)
  (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
  (mutex-unlock! *http-mutex*))

(define (http-transport:dec-requests-count-and-close-all-connections)
  (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
  (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
    (if (> *http-requests-in-progress* 0)
	(if (> etime (current-seconds))
	    (begin
	      (thread-sleep! 0.05)
	      (loop etime))
	    (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
	(close-all-connections!)))
  (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
  (mutex-unlock! *http-mutex*))

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

;; This next block all imported en-mass from the api branch
(define *http-requests-in-progress* 0)
(define *http-connections-next-cleanup* (current-seconds))

(define (http-transport:get-time-to-cleanup)
  (let ((res #f))
    (mutex-lock! *http-mutex*)
    (set! res (> (current-seconds) *http-connections-next-cleanup*))
    (mutex-unlock! *http-mutex*)
    res))

(define (http-transport:inc-requests-count)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
  ;; Use this opportunity to slow things down iff there are too many requests in flight
  (if (> *http-requests-in-progress* 5)
      (begin
	(debug:print-info 0 "Whoa there buddy, ease up...")
	(thread-sleep! 1)))
  (mutex-unlock! *http-mutex*))

(define (http-transport:dec-requests-count proc) 
  (mutex-lock! *http-mutex*)
  (proc)
  (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
  (mutex-unlock! *http-mutex*))

(define (http-transport:dec-requests-count-and-close-all-connections)
  (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
  (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
    (if (> *http-requests-in-progress* 0)
	(if (> etime (current-seconds))
	    (begin
	      (thread-sleep! 0.05)
	      (loop etime))
	    (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
	(close-all-connections!)))
  (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
  (mutex-unlock! *http-mutex*))

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

;; (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 4")

;; <html>
;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result

			 #t))   ;;  		 (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
       ;; (set! numretries (- numretries 1))
       ;;  		 #t))
       ;; send the data and get the response
       ;; extract the needed info from the http data and 
       ;; process and return it.
       (let* ((send-recieve (lambda ()
			      ;; (let ((dat #f)
			      ;;       (cleanup (http-transport:get-time-to-cleanup)))
			      ;;   (if cleanup 
			      ;;       (begin
			      ;;         (debug:print-info 0 "Running cleanup mode")
			      ;;         (http-transport:inc-requests-and-prep-to-close-all-connections))
			      ;;       (http-transport:inc-requests-count))
			      ;;   ;; Do the actual data transfer
			      (mutex-lock! *http-mutex*) ;; Hypothesis is that this was *not* the bottleneck
			      (set! res (with-input-from-request ;; was set! dat
					   fullurl 
					   (list (cons 'dat msg)) 
					   read-string))
			      (close-all-connections!)
			      (mutex-unlock! *http-mutex*)
			      ))
			      ;;(if cleanup
			      ;;      ;; mutex already set
			      ;;      (begin
			      ;;        (set! res dat)
			      ;;        (http-transport:dec-requests-count-and-close-all-connections))
			      ;;      (http-transport:dec-requests-count
			      ;;       (lambda ()
			      ;;         (set! res dat)))))))
	      (time-out     (lambda ()
			      (thread-sleep! 45)
			      (if (not res)
				  (begin
				    (debug:print 0 "WARNING: communication with the server timed out.")
				    (mutex-unlock! *http-mutex*)
				    (http-transport:client-send-receive serverdat msg numretries: (- numretries 1))

	 (thread-terminate! th2)
	 (debug:print-info 11 "got res=" res)
	 (let ((match (string-search (regexp "<body>(.*)<.body>") res)))
	   (debug:print-info 11 "match=" match)
	   (let ((final (cadr match)))
	     (debug:print-info 11 "final=" final)
	     final)))))))

;; Send "cmd" with json payload "params" to serverdat and receive result
;;
(define (http-transport:client-api-send-receive serverdat cmd params #!key (numretries 30))
  (let* ((fullurl    (if (list? serverdat)
			 (cadddr serverdat) ;; this is the uri for /api
			 (begin
			   (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info")
			   (exit 1))))
	 (res        #f))
    (handle-exceptions
     exn
     (begin
       ;; TODO: Send this output to a log file so it isn't lost when running as daemon
       (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
       (thread-sleep! 2)
       (if (> numretries 0)
	   (http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1))))
     (begin
       (debug:print-info 11 "fullurl=" fullurl "\n")
       ;; set up the http-client here
       (max-retry-attempts 5)
       ;; consider all requests indempotent
       (retry-request? (lambda (request)
			 #t))   ;;  		 (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
       ;; (set! numretries (- numretries 1))
       ;;  		 #t))
       ;; send the data and get the response
       ;; extract the needed info from the http data and 
       ;; process and return it.

       ;; (with-input-from-request "http://localhost/echo-service"
       ;;                  '((test . "value")) read-string)

       (let* ((send-recieve (lambda ()
			;;       (let ((dat #f)
			;; 	    (cleanup (http-transport:get-time-to-cleanup)))
			;; 	(if cleanup 
			;; 	    (http-transport:inc-requests-and-prep-to-close-all-connections)
			;; 	    (http-transport:inc-requests-count))
			;; 	;; Do the actual data transfer NB// KEPP THIS IN SYNC WITH http-transport:client-send-receive
				 (mutex-lock! *http-mutex*)
				 (set! res (with-input-from-request ;; was dat
					   fullurl 
					   (list (cons 'key "thekey")
						 (cons 'cmd cmd)
						 (cons 'params params))
					   read-string))
				 ;; Shouldn't this be a call to the managed call-all-connections stuff above?
				(close-all-connections!)
				(mutex-unlock! *http-mutex*)
				))
	                          ;; (if cleanup
				  ;;   ;; mutex already set
				  ;;   (begin
				  ;;     (set! res dat)
				  ;;     (http-transport:dec-requests-count-and-close-all-connections))
				  ;;   (http-transport:dec-requests-count
				  ;;    (lambda ()
				  ;;      (set! res dat)))))))
	      (time-out     (lambda ()
			      (thread-sleep! 45)
			      (if (not res)
				  (begin
				    (debug:print 0 "WARNING: communication with the server timed out.")
				    (mutex-unlock! *http-mutex*)
				    (http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1))
				    (if (< numretries 3) ;; on last try just exit
					(begin
					  (debug:print 0 "ERROR: communication with the server timed out. Giving up.")
					  (exit 1)))))))
	      (th1 (make-thread send-recieve "with-input-from-request"))
	      (th2 (make-thread time-out     "time out")))
	 (thread-start! th1)
	 (thread-start! th2)
	 (thread-join! th1)
	 (thread-terminate! th2)
	 (debug:print-info 11 "got res=" res)
	 res)))))

(define (http-transport:client-connect iface port)
  (let* ((login-res   #f)
	 (uri-dat     (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
	 (uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api"))))
	 (serverdat   (list iface port uri-dat uri-api-dat)))
    (set! *runremote* serverdat) ;; may or may not be good ...
    (set! login-res (rmt:login))
    (if (and (list? login-res)
	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" port)
	  (set! *runremote* serverdat)
	  serverdat)
	(begin
	  (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)

			   (if (and (string? tmo)
				    (string->number tmo))
			       (* 60 60 (string->number tmo))
			       ;; default to three days
			       (* 3 24 60 60)))))
    (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port)
    (let loop ((count 0))
      ;; Use this opportunity to sync the inmemdb to db
      (let ((start-time (current-milliseconds))
	    (sync-time  #f)
	    (rem-time   #f))
	(if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*))
	(set! sync-time  (- (current-milliseconds) start-time))
	(debug:print 0 "SYNC: time= " sync-time)
	(set! rem-time (quotient (- 4000 sync-time) 1000))
	(if (and (< rem-time 4)
		 (> rem-time 0))
	    (thread-sleep! rem-time)))

      ;; (thread-sleep! 4) ;; no need to do this very often



      (if (< count 1) ;; 3x3 = 9 secs aprox
	  (loop (+ count 1)))
      
      ;; Check that iface and port have not changed (can happen if server port collides)
      (mutex-lock! *heartbeat-mutex*)
      (set! sdat *runremote*)
      (mutex-unlock! *heartbeat-mutex*)
      
      (if (or (not (equal? sdat (list iface port)))
	      (not spid))
	  (begin 
	    (debug:print-info 0 "interface changed, refreshing iface and port info")
	    (set! iface (car sdat))
	    (set! port  (cadr sdat))
	    (set! spid  (tasks:server-get-server-id tdb #f iface port #f))))
      
      ;; NOTE: Get rid of this mechanism! It really is not needed...
      ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid)
      (tasks:server-update-heartbeat tdb spid)
      
      ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
      (mutex-lock! *heartbeat-mutex*)
      (set! last-access *last-db-access*)
      (mutex-unlock! *heartbeat-mutex*)
      ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
      (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))
	    (loop 0))
	  (begin
	    (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-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*))
	    (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
	    (thread-sleep! 1)
	    (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")
	    (exit))))))

;; all routes though here end in exit ...
(define (http-transport:launch)
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")

	(debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2))
	(if *toppath* 
	    (let* ((th2 (make-thread (lambda ()
				       (http-transport:run 
					(if (args:get-arg "-server")
					    (args:get-arg "-server")
					    "-"))) "Server run"))
		   (th3 (make-thread http-transport:keep-running "Keep running")))
;;		   (th1 (make-thread server:write-queue-handler  "write queue")))
	      (set! *cache-on* #t)
	      (set! *db*       (open-db))
	      (set! *inmemdb*  (open-in-mem-db))
	      (db:sync-tables (db:tbls *db*) *db* *inmemdb*) ;; (db:sync-to *db* *inmemdb*)

	      (thread-start! th2)
	      (thread-start! th3)
	      ;; (thread-start! th1)
	      (set! *didsomething* #t)
	      (thread-join! th2))
	    (debug:print 0 "ERROR: Failed to setup for megatest")))
    (exit)))

;; (use trace)
;; (trace http-transport:keep-running 

			       (list? x))
			     (map (lambda (x)
				    (debug:print 6 "item-assoc->item-list x: " x)
				    (if (< (length x) 2)
					(begin
					  (debug:print 0 "ERROR: malformed items spec " (string-intersperse x " "))
					  (list (car x)'()))
					(let* ((name (car x))
					       (items (cadr x))
					       (ilist (list name (if (string? items)
								     (string-split items)
								     '()))))
					  (if (null? ilist)
					      (debug:print 0 "ERROR: No items specified for " name))
					  ilist)))
				  itemsdat))))
	(let ((debuglevel 5))
	  (debug:print 5 "item-assoc->item-list: itemsdat => itemlst ")
	  (if (debug:debug-mode 5)
	      (begin
		(pp itemsdat)
		(print " => ")

			(if s (string-split s) #f))))
    (if valid-values
	(if (member item valid-values)
	    item #f)
	item)))

(define (items:get-items-from-config tconfig)
  (let* ((have-items  (hash-table-ref/default tconfig "items"      #f))
	 (have-itable (hash-table-ref/default tconfig "itemstable" #f))
	 (items       (hash-table-ref/default tconfig "items"      '()))
	 (itemstable  (hash-table-ref/default tconfig "itemstable" '())))
    (debug:print 5 "items: " items " itemstable: " itemstable)
    (set! items (map (lambda (item)
		       (if (procedure? (cadr item))
			   (list (car item)((cadr item)))
			   item))
		     items))
    (set! itemstable (map (lambda (item)
			    (if (procedure? (cadr item))
				(list (car item)((cadr item)))
				item))
			  itemstable))
    (if (and have-items  (null? items))     (debug:print 0 "ERROR: [items] section in testconfig but no entries defined"))
    (if (and have-itable (null? itemstable))(debug:print 0 "ERROR: [itemstable] section in testconfig but no entries defined"))
    (if (or (not (null? items))(not (null? itemstable)))
	(append (item-assoc->item-list items)
		(item-table->item-list itemstable))
	'(()))))

;; (pp (item-assoc->item-list itemdat))


	

(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))

(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses tdb))

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

;;======================================================================
;; ezsteps

	       (rollup-status 0))
	  (change-directory top-path)
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
	  ;; Setup the *runremote* global var
	  (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time"))
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (set! keys       (rmt:get-keys))
	  (set! keyvals    (keys:target->keyval keys target))
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
		(debug:print 4 "varpairs: " varpairs)
		(map (lambda (varpair)
		       (let ((varval (string-split varpair "=")))
			 (if (eq? (length varval) 2)
			     (let ((var (car varval))
				   (val (cadr varval)))
			       (debug:print 1 "Adding pre-var/val " var " = " val " to the environment")
			       (setenv var val)))))
		     varpairs)))
	  (for-each
	   (lambda (varval)
	     (let ((var (car varval))
		   (val (cadr varval)))
	       (if val
		   (setenv var val)
		   (begin
		     (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting")
		     (exit)))))
	     (list 
	      (list  "MT_TEST_RUN_DIR" work-area)
	      (list  "MT_TEST_NAME" test-name)
	      (list  "MT_ITEM_INFO" (conc itemdat))
	      (list  "MT_RUNNAME"   runname)
	      (list  "MT_MEGATEST"  megatest)
	      (list  "MT_TARGET"    target)
	      (list  "MT_LINKTREE"  (configf:lookup *configdat* "setup" "linktree"))))
	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
	  ;; (change-directory top-path)
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  ;; Can setup as client for server mode now
	  ;; (client:setup)

	  (change-directory *toppath*) 
	  (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  (change-directory work-area) 

	  (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (set-megatest-env-vars run-id 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 test-id run-id 0 work-area)

	  ;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
	  (tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a")
	  (thread-sleep! 0.3) ;; NFS slowness has caused grief here

	  ;; (cdb:set-test-start-time!  *runremote* test-id)
	  (if (args:get-arg "-xterm")
	      (set! fullrunscript "xterm")
	      (if (and fullrunscript (not (file-execute-access? fullrunscript)))
		  (system (conc "chmod ug+x " fullrunscript))))
	  ;; We are about to actually kick off the test
	  ;; so this is a good place to remove the records for 
	  ;; any previous runs

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

						   (debug:print 4 "script: " script)

						   (rmt:teststep-set-status! test-id stepname "start" "-" #f #f)
						   ;; now launch
						   (let ((pid (process-run script)))
						     (let processloop ((i 0))
						       (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
								   (mutex-lock! m)
								   (vector-set! exit-info 0 pid)
								   (vector-set! exit-info 1 exit-status)
								   (vector-set! exit-info 2 exit-code)
								   (mutex-unlock! m)
								   (if (eq? pid-val 0)
								       (begin
									 (thread-sleep! 2)
									 (processloop (+ i 1))))
								   ))
                                                     (let ((exinfo (vector-ref exit-info 2))
                                                           (logfna (if logpro-used (conc stepname ".html") "")))

						       (rmt:teststep-set-status! test-id stepname "end" exinfo #f logfna))
						     (if logpro-used
							 (rmt:test-set-log! test-id (conc stepname ".html")))
						     ;; set the test final status
						     (let* ((this-step-status (cond
									       ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
									       ((eq? (vector-ref exit-info 2) 0)                   'pass)
									       (else 'fail)))
							    (overall-status   (cond
									       ((eq? rollup-status 2) 'warn)
									       ((eq? rollup-status 0) 'pass)
									       (else 'fail)))
							    (next-status      (cond 
									       ((eq? overall-status 'pass) this-step-status)
									       ((eq? overall-status 'warn)
										(if (eq? this-step-status 'fail) 'fail 'warn))
									       (else 'fail)))
							    (next-state       ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ??
							                       (cond
									       ((null? tal) ;; more to run?
									        "COMPLETED")
									       (else "RUNNING")))
							    )
						       (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used 
								    " this-step-status: " this-step-status " overall-status: " overall-status 
								    " next-status: " next-status " rollup-status: " rollup-status)
						       (case next-status
							 ((warn)
							  (set! rollup-status 2)
							  ;; NB// test-set-status! does rdb calls under the hood
							  (tests:test-set-status! test-id next-state "WARN" 
									  (if (eq? this-step-status 'warn) "Logpro warning found" #f)
									  #f))
							 ((pass)
							  (tests:test-set-status! test-id next-state "PASS" #f #f))
							 (else ;; 'fail
							  (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" 
							  (tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
							  ))))
						   (if (and (steprun-good? logpro-used (vector-ref exit-info 2))
							    (not (null? tal)))
						       (loop (car tal) (cdr tal) stepname)))
						 (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
		 (monitorjob   (lambda ()
				 (let* ((start-seconds (current-seconds))
					(calc-minutes  (lambda ()
							 (inexact->exact 
							  (round 
							   (- 
							    (current-seconds) 
							    start-seconds)))))
					(kill-tries 0))
				   (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
				   (let loop ((minutes   (calc-minutes)))
				     (begin
				       (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat))
							   (and runtlim (let* ((run-seconds   (- (current-seconds) start-seconds))
									       (time-exceeded (> run-seconds runtlim)))
									  (if time-exceeded
									      (begin
										(debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
										#t)
									      #f)))))
				       ;; open-run-close not needed for test-set-meta-info
				       (tests:set-partial-meta-info test-id run-id minutes work-area)
				       (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* ((pid (vector-ref exit-info 0)))

						   ;;      	  (system (conc "kill -9 " p-id))))))
						   ;;      (car processes))
						   ;;     (system (conc "kill -9 -" pid))))
						   (begin
						     (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
						     (tests:test-set-status! test-id "KILLED"  "FAIL"
								     (args:get-arg "-m") #f)
						     (exit 1) ;; IS THIS NECESSARY OR WISE???
						     )))
					     (set! kill-tries (+ 1 kill-tries))
					     (mutex-unlock! m)))

				       (if keep-going
					   (begin
					     (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
					     (if keep-going
						 (loop (calc-minutes)))))))
				   (tests:update-central-meta-info test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional
		 (th1          (make-thread monitorjob "monitor job"))
		 (th2          (make-thread runit "run job")))
	    (set! job-thread th2)
	    (thread-start! th1)
	    (thread-start! th2)
	    (thread-join! th2)
	    (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 test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path)))
	      ;; 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

		    ;; (if (not (equal? item-path ""))
		    ;;     (begin
		    ;;       (thread-sleep! 0.1) ;; give other processes an opportunity to access the db as rollup is lower priority
		    ;;       (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))
		    ))
	      ;; for automated creation of the rollup html file this is a good place...
	      (if (not (equal? item-path ""))
		  (tests:summarize-items run-id test-id test-name #f))) ;; 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)))))))

;; set up the very basics needed for doing anything here.

			    (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! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))
	(set! *toppath*    (if (car *configinfo*)(cadr *configinfo*) #f))
	(if *toppath*
	    (let ((dbdir (conc *toppath* "/db")))
	      (handle-exceptions
	       exn
	       (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
	       (if (not (directory-exists? dbdir))(create-directory dbdir)))
	      (setenv "MT_RUN_AREA_HOME" *toppath*))
	    (debug:print 0 "ERROR: failed to find the top path to your Megatest area."))))
  *toppath*)

(define (get-best-disk confdat)
  (let* ((disks    (hash-table-ref/default confdat "disks" #f))
	 (best     #f)
	 (bestsize 0))

		      (if rd rd (conc *toppath* "/runs"))))

	 (lnkbase  (conc linktree "/" target "/" runname))
	 (lnkpath  (conc lnkbase "/" testname))
	 (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)))

    ;; Update the rundir path in the test record for all
    (rmt:general-call 'test-set-rundir-by-test-id lnkpathf test-id)

    (debug:print 2 "INFO:\n       lnkbase=" lnkbase "\n       lnkpath=" lnkpath "\n  toptest-path=" toptest-path "\n     test-path=" test-path)
    (if (not (file-exists? linktree))
	(begin
	  (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
	  (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
    ;; create the directory for the tests dir links, this is needed no matter what...
    (if (and (not (directory-exists? lnkbase))
	     (not (file-exists? lnkbase)))
	(create-directory lnkbase #t))
    
    ;; update the toptest record with its location rundir, cache the path
    ;; This wass highly inefficient, one db write for every subtest, potentially
    ;; thousands of unnecessary updates, cache the fact it was set and don't set it 
    ;; again. 

    ;; NB - This is not working right - some top tests are not getting the path set!!!

    (if (not (hash-table-ref/default *toptest-paths* testname #f))
	(let* ((testinfo       (rmt:get-test-info-by-id test-id)) ;;  run-id testname item-path))
	       (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f)))
	  (hash-table-set! *toptest-paths* testname curr-test-path)
	  ;; NB// Was this for the test or for the parent in an iterated test?
	  (rmt:general-call 'test-set-rundir lnkpath run-id testname "") ;; toptest-path)
	  (if (or (not curr-test-path)
		  (not (directory-exists? toptest-path)))
	      (begin
		(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
		(create-directory toptest-path #t)
		(hash-table-set! *toptest-paths* testname toptest-path)))))

	   exn
	   (begin
	     (debug:print 0 "ERROR:  Failed to re-create link " linktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
	     (exit))
	   (if (symbolic-link? lnktarget)     (delete-file lnktarget))
	   (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))










    (if (directory? test-path)
	(begin
	  (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
			   (if cmd
			       ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
			       (string-substitute "TEST_TARG_PATH" test-path
						  (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)

	 (launcher        (config-lookup *configdat* "jobtools"     "launcher"))
	 (runscript       (config-lookup test-conf   "setup"        "runscript"))
	 (ezsteps         (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big
	 (diskspace       (config-lookup test-conf   "requirements" "diskspace"))
	 (memory          (config-lookup test-conf   "requirements" "memory"))
	 (hosts           (config-lookup *configdat* "jobtools"     "workhosts"))
	 (remote-megatest (config-lookup *configdat* "setup" "executable"))
	 (run-time-limit  (or (configf:lookup  test-conf   "requirements" "runtimelim")
			      (configf:lookup  *configdat* "setup" "runtimelim")))
	 ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to 
	 ;;                allow running from dashboard. Extract the path
	 ;;                from the called megatest and convert dashboard
	 ;;             	  or dboard to megatest
	 (local-megatest  (let* ((lm  (car (argv)))
				 (dir (pathname-directory lm))
				 (exe (pathname-strip-directory lm)))

	 (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
	 (diskpath   #f)
	 (cmdparms   #f)
	 (fullcmd    #f) ;; (define a (with-output-to-string (lambda ()(write x))))
	 (mt-bindir-path #f)
	 (item-path (item-list->path itemdat))
	 ;; (test-id    (cdb:remote-run db:get-test-id #f run-id test-name item-path))
	 (testinfo   (rmt:get-test-info-by-id test-id))
	 (mt_target  (string-intersperse (map cadr keyvals) "/"))
	 (debug-param (append (if (args:get-arg "-debug")  (list "-debug" (args:get-arg "-debug")) '())
			      (if (args:get-arg "-logging")(list "-logging") '()))))
    (setenv "MT_ITEMPATH" item-path)
    (if hosts (set! hosts (string-split hosts)))
    ;; set the megatest to be called on the remote host
    (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))

				     (list 'runname   runname)
				     (list 'mt-bindir-path mt-bindir-path)))))))
    ;; clean out step records from previous run if they exist
    ;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
    ;; (open-run-close db:delete-test-step-records db test-id)
    (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
    (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
    ;; (cdb:set-test-start-time!  *runremote* test-id)
    (cond
     ((and launcher hosts) ;; must be using ssh hostname
      (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
     (launcher
      (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))

;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.5514)

(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(declare (uses db))
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

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

  -transport http|fs      : use http or direct access for transport (default is http) 
  -daemonize              : fork into background and disconnect from stdin/out
  -list-servers           : list the servers 
  -stop-server id         : stop server specified by id (see output of -list-servers), use
                            0 to kill all
  -repl                   : start a repl (useful for extending megatest)
  -load file.scm          : load and run file.scm
  -mark-incompletes       : find and mark incomplete tests

Spreadsheet generation
  -extract-ods fname.ods  : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted
                            to windows style

			"-runall"    ;; run all tests
			"-remove-runs"
			"-rebuild-db"
			"-cleanup-db"
			"-rollup"
			"-update-meta"
			"-gen-megatest-area"
			"-mark-incompletes"

			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))

      (for-each (lambda (x)
		  ;; (print "[" x "]"))
		  (print x))
		targets)
      (set! *didsomething* #t)))

(define (full-runconfigs-read)
  (let* ((keys   (rmt:get-keys))
	 (target (if (args:get-arg "-reqtarg")
		     (args:get-arg "-reqtarg")
		     (if (args:get-arg "-target")
			 (args:get-arg "-target")
			 #f)))
	 (key-vals (if target (keys:target->keyval keys target) #f))
	 (sections (if target (list "default" target) #f))

     (lambda (target runname keys keyvals)
       (operate-on 'set-state-status))))

;;======================================================================
;; Query runs
;;======================================================================

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (setup-for-run)
	(let* ((db       (open-db))
	       (runpatt  (args:get-arg "-list-runs"))
	       (testpatt (if (args:get-arg "-testpatt") 
			     (args:get-arg "-testpatt") 
			     "%"))
	       (runsdat  (db:get-runs db runpatt #f #f '()))
	       (runs     (db:get-rows runsdat))
	       (header   (db:get-header runsdat))
	       (keys     (db:get-keys db))
	       (db-targets (args:get-arg "-list-db-targets"))
	       (seen     (make-hash-table)))
	  ;; Each run
	  (for-each 
	   (lambda (run)
	     (let ((targetstr (string-intersperse (map (lambda (x)
							 (db:get-value-by-header run header x))
						       keys) "/")))
	       (if db-targets
		   (if (not (hash-table-ref/default seen targetstr #f))
		       (begin
			 (hash-table-set! seen targetstr #t)
			 ;; (print "[" targetstr "]"))))
			 (print targetstr))))
	       (if (not db-targets)
		   (let* ((run-id (db:get-value-by-header run header "id"))
			  (tests  (db:get-tests-for-run db run-id testpatt '() '() #f #f #f 'testname 'asc #f)))
		     (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") 
			    " status: " (db:get-value-by-header run header "state")
			    " run-id: " run-id ", number tests: " (length tests))
		     (for-each 
		      (lambda (test)
			(format #t
				"  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
				(conc (db:test-get-testname test)
				      (if (equal? (db:test-get-item-path test) "")
					  "" 
					  (conc "(" (db:test-get-item-path test) ")")))
				(db:test-get-state test)
				(db:test-get-status test)
				(db:test-get-run_duration test)
				(db:test-get-event_time test)
				(db:test-get-host test))
			(if (not (or (equal? (db:test-get-status test) "PASS")
			   	     (equal? (db:test-get-status test) "WARN")
				     (equal? (db:test-get-state test)  "NOT_STARTED")))
			    (begin
			      (print   "         cpuload:  " (db:test-get-cpuload test)
				     "\n         diskfree: " (db:test-get-diskfree test)
				     "\n         uname:    " (db:test-get-uname test)
				     "\n         rundir:   " (db:test-get-rundir test)
				     )
			      ;; Each test
			      ;; DO NOT remote run
			      (let ((steps (db:get-steps-for-test db (db:test-get-id test))))
				(for-each 
				 (lambda (step)
				   (format #t 
					   "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
					   (tdb:step-get-stepname step)
					   (tdb:step-get-state step)
					   (tdb:step-get-status step)
					   (tdb:step-get-event_time step)))
				 steps)))))
		      tests)))))
	     runs)
	   (set! *didsomething* #t))))

;;======================================================================
;; full run

	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
		(exit 1)))
	  (let* ((keys     (rmt:get-keys))
		 ;; db:test-get-paths must not be run remote
		 (paths    (db:test-get-paths-matching db keys target (args:get-arg "-test-files"))))
	    (set! *didsomething* #t)
	    (for-each (lambda (path)
			(print path))
		      paths)))
	;; else do a general-run-call

	       (transport (assoc/default 'transport cmdinfo))
	       (testpath  (assoc/default 'testpath  cmdinfo))
	       (test-name (assoc/default 'test-name cmdinfo))
	       (runscript (assoc/default 'runscript cmdinfo))
	       (db-host   (assoc/default 'db-host   cmdinfo))
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (db        (open-db))
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status"))
	       (target    (args:get-arg "-target")))
	  (change-directory testpath)
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -archive, exiting")
		(exit 1)))
	  (let* ((keys     (db:get-keys db))
		 ;; DO NOT run remote
		 (paths    (db:test-get-paths-matching db keys target)))
	    (set! *didsomething* #t)
	    (for-each (lambda (path)
			(print path))
		      paths))
	  (if (sqlite3:database? db)(sqlite3:finalize! db)))
	;; else do a general-run-call
	(general-run-call 
	 "-test-paths"
	 "Get paths to tests"
	 (lambda (target runname keys keyvals)
	   (let* ((db       (open-db))
		  ;; DO NOT run remote
		  (paths    (db:test-get-paths-matching db keys target)))
	     (for-each (lambda (path)
			 (print path))
		       paths)
	     (sqlite3:finalize! db))))))

;;======================================================================
;; Extract a spreadsheet from the runs database
;;======================================================================

(if (args:get-arg "-extract-ods")
    (general-run-call
     "-extract-ods"
     "Make ods spreadsheet"
     (lambda (target runname keys keyvals)
       (let ((db         (open-db))
	     (outputfile (args:get-arg "-extract-ods"))
	     (runspatt   (args:get-arg ":runname"))
	     (pathmod    (args:get-arg "-pathmod")))
	     ;; (keyvalalist (keys->alist keys "%")))
	 (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
	 (db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod)
	 (sqlite3:finalize! db)
	 (set! *didsomething* #t)))))

;;======================================================================
;; execute the test
;;    - gets called on remote host
;;    - receives info from the -execute param
;;    - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
;;    - gathers host info and 

	;; The transport is handled earlier in the loading process of megatest.
	;; (set! *transport-type* (string->symbol transport))
	(if (not (setup-for-run))
	    (begin
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(if (and state status)

	    (rmt:teststep-set-status! test-id step state status msg logfile)
	    (begin
	      (debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
	      (exit 6))))))

(if (args:get-arg "-step")
    (begin
      (megatest:step 

	  (change-directory work-area)
	  ;; can setup as client for server mode now
	  ;; (client:setup)

	  (if (args:get-arg "-load-test-data")
	      ;; has sub commands that are rdb:
	      ;; DO NOT put this one into either cdb:remote-run or open-run-close
	      (tdb:load-test-data test-id))
	  (if (args:get-arg "-setlog")
	      (let ((logfname (args:get-arg "-setlog")))
		(rmt:test-set-log! test-id logfname)))
	  (if (args:get-arg "-set-toplog")
	      ;; DO NOT run remote
	      (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      ;; DO NOT run remote
	      (tests:summarize-items db run-id test-id test-name #t)) ;; do force here
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
		    (debug:print 0 "ERROR: nothing specified to run!")

				       ((tcsh csh ksh)    ">&")
				       ((zsh bash sh ash) "2>&1 >")
				       (else ">&")))
			 (fullcmd    (conc "(" (string-intersperse 
						(cons cmd params) " ")
					   ") " redir " " logfile)))
		    ;; mark the start of the test

		    (rmt:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
		    ;; run the test step
		    (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir)
		    (change-directory startingdir)
		    (set! exitstat (system fullcmd))
		    (set! *globalexitstatus* exitstat)
		    ;; (change-directory testpath)
		    ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
		    (if logprofile
			(let* ((htmllogfile (conc stepname ".html"))
			       (oldexitstat exitstat)
			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
			  (debug:print-info 2 "running \"" cmd "\"")
			  (change-directory startingdir)
			  (set! exitstat (system cmd))
			  (set! *globalexitstatus* exitstat) ;; no necessary
			  (change-directory testpath)
			  (rmt:test-set-log! test-id htmllogfile)))
		    (let ((msg (args:get-arg "-m")))

		      (rmt:teststep-set-status! test-id stepname "end" exitstat msg logfile))
		    )))
	  (if (or (args:get-arg "-test-status")
		  (args:get-arg "-set-values"))
	      (let ((newstatus (cond
				((number? status)       (if (equal? status 0) "PASS" "FAIL"))
				((and (string? status)
				      (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))