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

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

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

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

;;======================================================================
;; 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))
	 (write-access (file-write-access? dbpath))
	 (db           (sqlite3:open-database dbpath)) ;; (never-give-up-open-db 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))
    (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)))

;; 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)
  (let* ((db   (if idb 
		   (if (procedure? idb)
		       (idb)
		       idb)

     (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,"
			 "state TEXT DEFAULT '',"
			 "status TEXT DEFAULT '',"
			 "owner TEXT DEFAULT '',"
			 "event_time TIMESTAMP,"
			 "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,
                               testname     TEXT,
                               host         TEXT DEFAULT 'n/a',
                               cpuload      REAL DEFAULT -1,
                               diskfree     INTEGER DEFAULT -1,
                               uname        TEXT DEFAULT 'n/a', 
                               rundir_id    INTEGER,
                               realdir_id   INTEGER,
                               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       BLOB, 
                               run_duration INTEGER DEFAULT 0,
                               comment      TEXT DEFAULT '',
                               event_time   TIMESTAMP,
                               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,
                               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


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
















































































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

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

			(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      #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)
  ;; (common:clear-caches) ;; don't trust caches after doing any deletion
  ;; 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)))

;;======================================================================
;; 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
			      #!key
			      (qryvals #f)
			      )
  (let* ((qryvals         (if qryvals qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment"))
	 (res            '())
	 ;; if states or statuses are null then assume match all when not-in is false
	 (states-qry      (if (null? states) 

	   (states-qry  
	    (conc " AND " states-qry))
	   (statuses-qry 
	    (conc " AND " statuses-qry))
	   (else "")))
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT " qryvals
				" 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)
    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))

;; this one is a bit broken BUG FIXME
(define (db:delete-test-step-records dbstruct run-id test-id)

  (let ((db (db:get-db dbstruct run-id)))



    (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id)
    (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id)))


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






  (let ((db (db:get-db dbstruct run-id)))

    (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id)
    (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id)

    ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)
    (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))

(define (db:delete-tests-for-run 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))


;; (define (cdb:set-tests-state-status-faster serverdat run-id testnames currstate currstatus newstate newstatus)
;;   ;; Convert #f to wildcard %
;;   (if (null? testnames)
;;       #t
;;       (let ((currstate  (if currstate currstate "%"))
;; 	    (currstatus (if currstatus currstatus "%")))
;; 	(let loop ((hed (car testnames))
;; 		   (tal (cdr testnames))
;; 		   (thr '()))
;; 	  (let ((th1 (if newstate  (create-thread (cbd:client-call serverdat 'update-test-state  #t *default-numtries* newstate  currstate  run-id testname testname)) #f))
;; 		(th2 (if newstatus (create-thread (cbd:client-call serverdat 'update-test-status #t *default-numtries* newstatus currstatus run-id testname testname)) #f)))
;; 	    (thread-start! th1)
;; 	    (thread-start! th2)
;; 	    (if (null? tal)
;; 		(loop (car tal)(cdr tal)(cons th1 (cons th2 thr)))
;; 		(for-each
;; 		 (lambda (th)
;; 		   (if th (thread-join! th)))
;; 		 thr)))))))

(define (db:delete-tests-in-state dbstruct run-id state)

  (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'delete-tests-in-state) state))

(define (db:tests-update-cpuload-diskfree dbstruct run-id test-id cpuload diskfree)
  (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'update-cpuload-diskfree) cpuload diskfree test-id))

(define (db:tests-update-run-duration dbstruct run-id test-id minutes)
  (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'update-run-duration) minutes test-id))

(define (db:tests-update-uname-host dbstruct run-id test-id uname hostname)
  (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'update-uname-host) uname hostname test-id))

;; speed up for common cases with a little logic
;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
(define (db:test-set-state-status-by-id 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))))
    (mt:process-triggers run-id test-id newstate newstatus)))

;; Never used
;; (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)
  (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.
;;
;; 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-set-comment dbstruct run-id test-id comment)





  (sqlite3:execute 




   (db:get-db dbstruct run-id)

   "UPDATE tests SET comment=? WHERE id=?;"
   comment test-id))

(define (db:test-set-rundir! dbstruct run-id test-name item-path rundir-id)
  (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'test-set-rundir) test-name item-path))


(define (db:test-set-rundir-by-test-id dbstruct run-id test-id rundir-id)
  (sqlite3:execute (db:get-db dbstruct run-id) 'test-set-rundir-by-test-id rundir-id test-id))










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

(define (db:test-set-log! dbstruct run-id test-id logf-id)
  (if (string? logf)(sqlite3:execute (db:get-db dbstruct run-id) 'test-set-log logf-id test-id)))

;;======================================================================
;; 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 (db:test-get-paths-matching-keynames-target-new dbstruct keynames target res
					testpatt:   testpatt
					statepatt:  statepatt
					statuspatt: statuspatt
					runname:    runname)))
    (if fnamepatt
	(apply append 
	       (map (lambda (p)

    (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 
							#!key
							(testpatt   "%")
							(statepatt  "%")
							(statuspatt "%")
							(runname    "%"))
  (let* ((row-ids '())
	 (keystr (string-intersperse 
		  (map (lambda (key val)
			 (conc key " like '" val "'"))
		       keynames 
		       (string-split target "/"))
		  " AND "))
	 (testqry (tests:match->sqlqry testpatt))
	 (runsqry (sqlite3:prepare (db: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;")))
    (sqlite3:for-each-row
     (lambda (rid)
       (set! row-ids (cons rid row-ids)))
     runsqry)
    (for-each (lambda (rid)
		(sqlite3:for-each-row 
		 (lambda (p)
		   (set! res (cons p res)))
		 (db:get-db dbstruct rid)
		 tstsqry))
	      row-ids)
    ;; (sqlite3:finalize! tstsqry)
    (sqlite3:finalize! runsqry)
    res))

;; NEVER FINISHED? ;; look through tests from matching runs for a file
;; NEVER FINISHED? (define (db:test-get-first-path-matching dbstruct keynames target fname)
;; NEVER FINISHED?   ;; [refpaths] is the section where references to other megatest databases are stored
;; NEVER FINISHED? ;;
;; NEVER FINISHED? ;; NEED TO REVISIT THIS!!! BUGGISHNESS
;; NEVER FINISHED? ;;
;; NEVER FINISHED?   (let ((mt-paths (configf:get-section "refpaths"))
;; NEVER FINISHED? 	(res       (db:test-get-paths-matching dbstruct keynames target fname)))
;; NEVER FINISHED?     (let loop ((pathdat (if (null? paths) #f (car mt-paths)))
;; NEVER FINISHED? 	       (tal     (if (null? paths) '()(cdr mt-paths))))
;; NEVER FINISHED?       (if (not (null? res))
;; NEVER FINISHED? 	  (car res) ;; return first found
;; NEVER FINISHED? 	  (if path
;; NEVER FINISHED? 	      (let* ((db     (open-db path: (cadr pathdat)))
;; NEVER FINISHED? 		     (newres (db:test-get-paths-matching db keynames target fname)))
;; NEVER FINISHED? 		(debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat))
;; NEVER FINISHED? 		(sqlite3:finalize! db)
;; NEVER FINISHED? 		(if (not (null? newres))
;; NEVER FINISHED? 		    (car newres)
;; NEVER FINISHED? 		    (if (null? tal)
;; NEVER FINISHED? 			#f
;; NEVER FINISHED? 			(loop (car tal)(cdr tal))))))))))

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

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj)

;;
;; cdb:client-call is the unified interface to all the transports. It dispatches the
;;                 query to a server routine (e.g. server:client-send-recieve) that 
;;                 transports the data to the server where it is passed to db:process-queue-item
;;                 which either returns the data to the calling server routine or 
;;                 directly calls the returning procedure (e.g. zmq).
;;
;; (define (cdb:client-call serverdat qtype immediate numretries . params)
;;   (debug:print-info 11 "cdb:client-call serverdat=" serverdat ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params)
;;   (case *transport-type* 
;;     ((fs)
;;      (let ((packet (vector "na" qtype immediate "na" params 0)))
;;        (fs:process-queue-item packet)))
;;     ((http)
;;      (let* ((client-sig  (client:get-signature))
;; 	    (query-sig   (message-digest-string (md5-primitive) (conc qtype immediate params)))
;; 	    (zdat        (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params))))
;;        (debug:print-info 11 "zdat=" zdat)
;;        (let* ((res  #f)
;; 	      (rawdat      (http-transport:client-send-receive serverdat zdat))
;; 	      (tmp         #f))
;; 	 (debug:print-info 11 "Sent " zdat ", received " rawdat)
;; 	 (if rawdat
;; 	     (begin
;; 	       (set! tmp (db:string->obj rawdat))
;; 	       (vector-ref tmp 2))
;; 	     (begin
;; 	       (debug:print 0 "ERROR: Communication with the server failed. Exiting if possible")
;; 	       (exit 1))))))
;;     ((zmq)
;;      (handle-exceptions
;;       exn
;;       (begin
;; 	(debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds")
;; 	(thread-sleep! 5) 
;; 	(if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params)))
;;       (let* ((push-socket (vector-ref serverdat 0))
;; 	     (sub-socket  (vector-ref serverdat 1))
;; 	     (client-sig  (client:get-signature))
;; 	     (query-sig   (message-digest-string (md5-primitive) (conc qtype immediate params)))
;; 	     (zdat        (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params))))
;; 	     (res  #f)
;; 	     (send-receive (lambda ()
;; 			     (debug:print-info 11 "sending message")
;; 			     (send-message push-socket zdat)
;; 			     (debug:print-info 11 "message sent")
;; 			     (let loop ()
;; 			       ;; get the sender info
;; 			       ;; this should match (client:get-signature)
;; 			       ;; we will need to process "all" messages here some day
;; 			       (receive-message* sub-socket)
;; 			       ;; now get the actual message
;; 			       (let ((myres (db:string->obj (receive-message* sub-socket))))
;; 				 (if (equal? query-sig (vector-ref myres 1))
;; 				     (set! res (vector-ref myres 2))
;; 				     (loop)))))))
;; 	;; (timeout (lambda ()
;; 	;;     	(let loop ((n numretries))
;; 	;;     	  (thread-sleep! 15)
;; 	;;     	  (if (not res)
;; 	;;     	      (if (> numretries 0)
;; 	;;     		  (begin
;; 	;;     		    (debug:print 2 "WARNING: no reply to query " params ", trying resend")
;; 	;;     		    (debug:print-info 11 "re-sending message")
;; 	;;     		    (send-message push-socket zdat)
;; 	;;     		    (debug:print-info 11 "message re-sent")
;; 	;;     		    (loop (- n 1)))
;; 	;;     		  ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params))
;; 	;;     		  (begin
;; 	;;     		    (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.")
;; 	;;     		    (exit 5))))))))
;; 	(debug:print-info 11 "Starting threads")
;; 	(let ((th1 (make-thread send-receive "send receive"))
;; 	      ;; (th2 (make-thread timeout      "timeout"))

;; 	      )
;; 	  (thread-start! th1)
;; 	  ;; (thread-start! th2)
;; 	  (thread-join!  th1)
;; 	  (debug:print-info 11 "cdb:client-call returning res=" res)
;; 	  res))))))

;; NOT NEEDED FOR NOW (define (cdb:set-verbosity serverdat val)
;; NOT NEEDED FOR NOW   (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))
;; NOT NEEDED FOR NOW 
;; NOT NEEDED FOR NOW (define (cdb:login serverdat keyval signature)
;; NOT NEEDED FOR NOW   (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))
;; NOT NEEDED FOR NOW 
;; NOT NEEDED FOR NOW (define (cdb:logout serverdat keyval signature)
;; NOT NEEDED FOR NOW   (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature))
;; NOT NEEDED FOR NOW 
;; NOT NEEDED FOR NOW (define (cdb:num-clients serverdat)
;; NOT NEEDED FOR NOW   (cdb:client-call serverdat 'numclients #t *default-numtries*))
;; NOT NEEDED FOR NOW 

;; I think this would be more efficient if executed on client side FIXME???
(define (db:test-set-status-state dbstruct run-id test-id status state msg-id)
  (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
      (sqlite3:execute (db:get-db dbstruct run-id) 'set-test-start-time test-id))
  (if msg
      (sqlite3:execute (db:get-db dbstruct run-id) 'state-status-msg state status msg-id test-id)
      (sqlite3:execute (db:get-db dbstruct run-id) 'state-status state status test-id)))

(define (db:test-rollup-test_data-pass-fail dbstruct run-id test-id)
  (sqlite3:execute (db:get-db dbstruct run-id) 'test_data-pf-rollup test-id test-id test-id test-id))

(define (db:pass-fail-counts dbstruct run-id test-id fail-count pass-count)
  (sqlite3:execute (db:get-db dbstruct run-id) 'pass-fail-counts fail-count pass-count test-id))

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

;; more transactioned calls, these for roll-up-pass-fail stuff
(define (db:update-pass-fail-counts dbstruct run-id test-name)
  (sqlite3:execute (db:get-db dbstruct run-id) 'update-fail-pass-counts test-name test-name test-name))

(define (db:top-test-set-running dbstruct run-id test-name)
  (sqlite3:execute (db:get-db dbstruct run-id) 'top-test-set-running test-name))

(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
  (sqlite3:execute (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts test-name test-name test-name))

;;=

;; NOT NEEDED FOR NOW (define (cdb:flush-queue serverdat)
;; NOT NEEDED FOR NOW   (cdb:client-call serverdat 'flush #f *default-numtries*))
;; NOT NEEDED FOR NOW 
;; NOT NEEDED FOR NOW (define (cdb:kill-server serverdat pid)
;; NOT NEEDED FOR NOW   (cdb:client-call serverdat 'killserver #t *default-numtries* pid))

;; (define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status)
;;  (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status))
;; 
;; (define (db:get-test-info serverdat run-id test-name item-path)
;;   (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path))
;; 
;; (define (cdb:get-test-info-by-id serverdat test-id)
;;   (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)))
;;     (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed
;;     test-dat))
;; 
;; ;; db should be db open proc or #f
;; (define (cdb:remote-run proc db . params)
;;   (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params))
;; 

(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 '(register-test          "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; DONE
	;; 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 fail_count=?,pass_count=? WHERE id=?;") ;; DONE
	;; 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-run-duration     "UPDATE tests SET run_duration=? 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-fail-pass-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
	))

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

;; not used, intended to indicate to run in calling process
(define db:run-local-queries '()) ;; rollup-tests-pass-fail))

;; DISABLING FOR NOW (define (db:process-cached-writes db)
;; DISABLING FOR NOW   (let ((queries    (make-hash-table))
;; DISABLING FOR NOW 	(data       #f))
;; DISABLING FOR NOW     (mutex-lock! *incoming-mutex*)
;; DISABLING FOR NOW     ;; data is a list of query packets <vector qry-sig query params
;; DISABLING FOR NOW     (set! data (reverse *incoming-writes*)) ;;  (sort ... (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))
;; DISABLING FOR NOW     (set! *server:last-write-flush* (current-milliseconds))
;; DISABLING FOR NOW     (set! *incoming-writes* '())
;; DISABLING FOR NOW     (mutex-unlock! *incoming-mutex*)
;; DISABLING FOR NOW     (if (> (length data) 0)
;; DISABLING FOR NOW 	;; Process if we have data
;; DISABLING FOR NOW 	(begin
;; DISABLING FOR NOW 	  (debug:print-info 7 "Writing cached data " data)
;; DISABLING FOR NOW 	  
;; DISABLING FOR NOW 	  ;; Prepare the needed sql statements
;; DISABLING FOR NOW 	  ;;
;; DISABLING FOR NOW 	  (for-each (lambda (request-item)
;; DISABLING FOR NOW 		      (let ((stmt-key (vector-ref request-item 0))
;; DISABLING FOR NOW 			    (query    (vector-ref request-item 1)))
;; DISABLING FOR NOW 			(hash-table-set! queries stmt-key (sqlite3:prepare db query))))
;; DISABLING FOR NOW 		    data)
;; DISABLING FOR NOW 	  
;; DISABLING FOR NOW 	  ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue
;; DISABLING FOR NOW 	  ;; and then are executed.
;; DISABLING FOR NOW 	  (sqlite3:with-transaction 
;; DISABLING FOR NOW 	   db
;; DISABLING FOR NOW 	   (lambda ()
;; DISABLING FOR NOW 	     (for-each
;; DISABLING FOR NOW 	      (lambda (hed)
;; DISABLING FOR NOW 		(let* ((params   (vector-ref hed 2))
;; DISABLING FOR NOW 		       (stmt-key (vector-ref hed 0))
;; DISABLING FOR NOW 		       (stmt     (hash-table-ref/default queries stmt-key #f)))
;; DISABLING FOR NOW 		  (if stmt
;; DISABLING FOR NOW 		      (apply sqlite3:execute stmt params)
;; DISABLING FOR NOW 		      (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params))))
;; DISABLING FOR NOW 	      data)))
;; DISABLING FOR NOW 	  
;; DISABLING FOR NOW 	  ;; let all the waiting calls know all is done
;; DISABLING FOR NOW 	  (mutex-lock! *completed-mutex*)
;; DISABLING FOR NOW 	  (for-each (lambda (item)
;; DISABLING FOR NOW 		      (let ((qry-sig (cdb:packet-get-client-sig item)))
;; DISABLING FOR NOW 			(debug:print-info 7 "Registering query " qry-sig " as done")
;; DISABLING FOR NOW 			(hash-table-set! *completed-writes* qry-sig #t)))
;; DISABLING FOR NOW 		    data)
;; DISABLING FOR NOW 	  (mutex-unlock! *completed-mutex*)
;; DISABLING FOR NOW 	  
;; DISABLING FOR NOW 	  ;; Finalize the statements. Should this be done inside the mutex above?
;; DISABLING FOR NOW 	  ;; I think sqlite3 mutexes will keep the data safe
;; DISABLING FOR NOW 	  (for-each (lambda (stmt-key)
;; DISABLING FOR NOW 		      (sqlite3:finalize! (hash-table-ref queries stmt-key)))
;; DISABLING FOR NOW 		    (hash-table-keys queries))
;; DISABLING FOR NOW 	  
;; DISABLING FOR NOW 	  ;; Do a little record keeping
;; DISABLING FOR NOW 	  (let ((cache-size (length data)))
;; DISABLING FOR NOW 	    (if (> cache-size *max-cache-size*)
;; DISABLING FOR NOW 		(set! *max-cache-size* cache-size)))
;; DISABLING FOR NOW 	  #t)
;; DISABLING FOR NOW 	#f)))
;; DISABLING FOR NOW 
;; DISABLING FOR NOW (define *db:process-queue-mutex* (make-mutex))
;; 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 
;; DISABLING FOR NOW ;; values to be applied
;; DISABLING FOR NOW ;;




;; DISABLING FOR NOW (define (db:queue-write-and-wait db qry-sig query params)
;; DISABLING FOR NOW   (let ((queue-len  0)
;; DISABLING FOR NOW 	(res        #f)
;; DISABLING FOR NOW 	(got-it     #f)
;; DISABLING FOR NOW 	(qry-pkt    (vector qry-sig query params))
;; DISABLING FOR NOW 	(start-time (current-milliseconds))
;; DISABLING FOR NOW 	(timeout    (+ 10 (current-seconds)))) ;; set the time out to 10 secs in future
;; DISABLING FOR NOW 
;; DISABLING FOR NOW     ;; Put the item in the queue *incoming-writes* 
;; DISABLING FOR NOW     (mutex-lock! *incoming-mutex*)
;; DISABLING FOR NOW     (set! *incoming-writes* (cons qry-pkt *incoming-writes*))
;; DISABLING FOR NOW     (set! queue-len (length *incoming-writes*))
;; DISABLING FOR NOW     (mutex-unlock! *incoming-mutex*)
;; DISABLING FOR NOW 
;; DISABLING FOR NOW     (debug:print-info 7 "Current write queue length is " queue-len)
;; DISABLING FOR NOW 
;; DISABLING FOR NOW     ;; poll for the write to complete, timeout after 10 seconds
;; DISABLING FOR NOW     ;; periodic flushing of the queue is taken care of by 
;; DISABLING FOR NOW     ;; db:flush-queue
;; DISABLING FOR NOW     (let loop ()
;; DISABLING FOR NOW       (thread-sleep! 0.001)
;; DISABLING FOR NOW       (mutex-lock! *completed-mutex*)
;; DISABLING FOR NOW       (if (hash-table-ref/default *completed-writes* qry-sig #f)
;; DISABLING FOR NOW 	  (begin
;; DISABLING FOR NOW 	    (hash-table-delete! *completed-writes* qry-sig)
;; DISABLING FOR NOW 	    (set! got-it #t)))
;; DISABLING FOR NOW       (mutex-unlock! *completed-mutex*)
;; DISABLING FOR NOW       (if (and (not got-it)
;; DISABLING FOR NOW 	       (< (current-seconds) timeout))
;; DISABLING FOR NOW 	  (begin
;; DISABLING FOR NOW 	    (thread-sleep! 0.01)
;; DISABLING FOR NOW 	    (loop))))
;; DISABLING FOR NOW     (set! *number-of-writes*   (+ *number-of-writes*   1))
;; DISABLING FOR NOW     (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time)))
;; DISABLING FOR NOW     got-it))
;; DISABLING FOR NOW 
;; DISABLING FOR NOW (define (db:process-queue-item db item)
;; DISABLING FOR NOW   (let* ((stmt-key       (cdb:packet-get-qtype item))
;; DISABLING FOR NOW 	 (qry-sig        (cdb:packet-get-query-sig item))
;; DISABLING FOR NOW 	 (return-address (cdb:packet-get-client-sig item))
;; DISABLING FOR NOW 	 (params         (cdb:packet-get-params item))
;; DISABLING FOR NOW 	 (query          (let ((q (alist-ref stmt-key db:queries)))
;; DISABLING FOR NOW 			   (if q (car q) #f))))
;; DISABLING FOR NOW     (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params)
;; DISABLING FOR NOW     (if query
;; DISABLING FOR NOW 	;; hand queries off to the write queue
;; DISABLING FOR NOW 	(let ((response (case *transport-type*
;; DISABLING FOR NOW 			  ((http)
;; DISABLING FOR NOW 			   (debug:print-info 7 "Queuing item " item " for wrapped write")
;; DISABLING FOR NOW 			   (db:queue-write-and-wait db qry-sig query params))
;; DISABLING FOR NOW 			  (else  
;; DISABLING FOR NOW 			   (apply sqlite3:execute db query params)
;; DISABLING FOR NOW 			   #t))))
;; DISABLING FOR NOW 	  (debug:print-info 7 "Received " response " from wrapped write")
;; DISABLING FOR NOW 	  (server:reply return-address qry-sig response response))
;; DISABLING FOR NOW 	;; otherwise if appropriate flush the queue (this is a read or complex query)
;; DISABLING FOR NOW 	(begin
;; DISABLING FOR NOW 	  (cond
;; DISABLING FOR NOW 	   ((member stmt-key db:special-queries)
;; DISABLING FOR NOW 	    (let ((starttime (current-milliseconds)))
;; DISABLING FOR NOW 	      (debug:print-info 9 "Handling special statement " stmt-key)
;; DISABLING FOR NOW 	      (case stmt-key
;; DISABLING FOR NOW 		((immediate)
;; DISABLING FOR NOW 		 ;; This is a read or mixed read-write query, must clear the cache
;; DISABLING FOR NOW 		 (case *transport-type*
;; DISABLING FOR NOW 		   ((http)
;; DISABLING FOR NOW 		    (mutex-lock! *db:process-queue-mutex*)
;; DISABLING FOR NOW 		    (db:process-cached-writes db)
;; DISABLING FOR NOW 		    (mutex-unlock! *db:process-queue-mutex*)))
;; DISABLING FOR NOW 		 (let* ((proc      (car params))
;; DISABLING FOR NOW 			(remparams (cdr params))
;; DISABLING FOR NOW 			;; we are being handed a procedure so call it
;; DISABLING FOR NOW 			;; (debug:print-info 11 "Running (apply " proc " " remparams ")")
;; DISABLING FOR NOW 			(result (server:reply return-address qry-sig #t (apply proc remparams))))
;; DISABLING FOR NOW 		   (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) 
;; DISABLING FOR NOW 		   (set! *number-non-write-queries* (+ *number-non-write-queries* 1))
;; DISABLING FOR NOW 		   result))
;; DISABLING FOR NOW 		((login)
;; DISABLING FOR NOW 		 (if (< (length params) 3) ;; should get toppath, version and signature
;; DISABLING FOR NOW 		     (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params
;; DISABLING FOR NOW 		     (let ((calling-path (car   params))
;; DISABLING FOR NOW 			   (calling-vers (cadr  params))
;; DISABLING FOR NOW 			   (client-key   (caddr params)))
;; DISABLING FOR NOW 		       (if (and (equal? calling-path *toppath*)
;; DISABLING FOR NOW 				(equal? megatest-version calling-vers))
;; DISABLING FOR NOW 			   (begin
;; DISABLING FOR NOW 			     (hash-table-set! *logged-in-clients* client-key (current-seconds))
;; DISABLING FOR NOW 			     (server:reply return-address qry-sig #t '(#t "successful login")))      ;; path matches - pass! Should vet the caller at this time ...
;; DISABLING FOR NOW 			   (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
;; DISABLING FOR NOW 		((flush sync)
;; DISABLING FOR NOW 		 (server:reply return-address qry-sig #t 1)) ;; (length data)))
;; DISABLING FOR NOW 		((set-verbosity)
;; DISABLING FOR NOW 		 (set! *verbosity* (car params))
;; DISABLING FOR NOW 		 (server:reply return-address qry-sig #t (list #t *verbosity*)))
;; DISABLING FOR NOW 		((killserver)
;; DISABLING FOR NOW 		 (let ((hostname (car  *runremote*))
;; DISABLING FOR NOW 		       (port     (cadr *runremote*))
;; DISABLING FOR NOW 		       (pid      (car params)))
;; DISABLING FOR NOW 		   (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
;; DISABLING FOR NOW 		   (debug:print-info 1 "current pid=" (current-process-id))
;; DISABLING FOR NOW 		   (open-run-close tasks:server-deregister tasks:open-db 
;; DISABLING FOR NOW 				   hostname
;; DISABLING FOR NOW 				   port: port)
;; DISABLING FOR NOW 		   (set! *server-run* #f)
;; DISABLING FOR NOW 		   (thread-sleep! 3)
;; DISABLING FOR NOW 		   (process-signal pid signal/kill)
;; DISABLING FOR NOW 		   (server:reply return-address qry-sig #t '(#t "exit process started"))))
;; DISABLING FOR NOW 		(else ;; not a command, i.e. is a query
;; DISABLING FOR NOW 		 (debug:print 0 "ERROR: Unrecognised query/command " stmt-key)
;; DISABLING FOR NOW 		 (server:reply return-address qry-sig #f 'failed)))))
;; DISABLING FOR NOW 	   (else
;; DISABLING FOR NOW 	    (debug:print-info 11 "Executing " stmt-key " for " params)
;; DISABLING FOR NOW 	    (apply sqlite3:execute (hash-table-ref queries stmt-key) params)
;; DISABLING FOR NOW 	    (server:reply return-address qry-sig #t #t)))))))
;; DISABLING FOR NOW 

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

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

(define (db:csv->test-data dbstruct run-id test-id 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)(db:get-prev-tol-for-test dbstruct run-id 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:get-db dbstruct run-id) "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)))


;; get a list of test_data records matching categorypatt
(define (db:read-test-data dbstruct run-id test-id categorypatt)


  (let ((res '()))
    (sqlite3:for-each-row 
     (lambda (id test_id category variable value expected tol units comment status type)
       (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
     (db:get-db dbstruct run-id)
     "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)

    (reverse res)))


;; NOTE: Run this local with #f for db !!!
(define (db:load-test-data dbstruct run-id test-id)
  (let loop ((lin (read-line)))
    (if (not (eof-object? lin))
	(begin
	  (debug:print 4 lin)
	  (db:csv->test-data dbstruct run-id test-id lin)
	  (loop (read-line)))))
  ;; roll up the current results.
  ;; FIXME: Add the status to 
  (db:test-data-rollup dbstruct run-id test-id #f))

;; WARNING: Do NOT call this for the parent test on an iterated test
;; Roll up test_data pass/fail results
;; look at the test_data status field, 
;;    if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;;    if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup dbstruct run-id test-id status)

  (let ((fail-count 0)
	(pass-count 0))


    (sqlite3:for-each-row
     (lambda (fcount pcount)
       (set! fail-count fcount)
       (set! pass-count pcount))
     (db:get-db dbstruct run-id)
     "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
    (cdb:pass-fail-counts *runremote* test-id fail-count pass-count)









    ;; if the test is not FAIL then set status based on the fail and pass counts.
    (cdb:test-rollup-test_data-pass-fail *runremote* test-id)))













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

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

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

;; db-get-test-steps-for-run
(define (db:get-steps-for-test dbstruct run-id 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:get-db dbstruct run-id)
     "SELECT id,test_id,stepname,state,status,event_time,logfile_id FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
     test-id)

    (reverse res)))


;; get a pretty table to summarize steps
;;
(define (db:get-steps-table dbstruct run-id test-id)
  (let ((steps   (db:get-steps-for-test dbstruct run-id test-id)))
    ;; 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 

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

;; ;; get a pretty table to summarize steps
;; ;;
;; (define (db:get-steps-table-list dbstruct run-id test-id #!key (work-area #f))
;;   (let ((steps   (db:get-steps-for-test dbstruct run-id test-id)))
;;     ;; 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    
;; 			(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 (db:get-compressed-steps dbstruct run-id test-id)


  (let ((comprsteps (open-run-close db:get-steps-table (db:get-db dbstruct run-id) test-id)))
    (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)))))))))


;;======================================================================
;; 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 #!key (mode 'normal))
  (if (or (not waitons)
	  (null? waitons))
      '()
      (let* ((unmet-pre-reqs '())
	     (result         '()))
	(for-each 
	 (lambda (waitontest-name)
	   ;; by getting the tests with matching name we are looking only at the matching test 
	   ;; and related sub items
	   (let ((tests             (mt:get-tests-for-run dbstruct 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))))

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



  (let ((state     (items:check-valid-items "state" state-in))
	(status    (items:check-valid-items "status" status-in)))
    (if (or (not state)(not status))
	(debug:print 3 "WARNING: Invalid " (if status "status" "state")
		     " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))


    (sqlite3:execute 
     (db:get-db dbstruct run-id)
     "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment_id,logfile_id) VALUES(?,?,?,?,?,?,?);"
     test-id teststep-name state-in status-in (current-seconds) 

     (db:save-string (if comment comment ""))
     (db:save-string (if logfile logfile "")))
    #t))


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

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

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

		  limit))
	 (vector header full-list)))))

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

(define (mt:get-tests-for-run dbstruct run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f))
  (let loop ((testsdat (db:get-tests-for-run dbstruct run-id testpatt states status 0 500 not-in sort-by sort-order qryvals: qryvals))
	     (res      '())
	     (offset   0)
	     (limit    500))
    (let* ((full-list (append res testsdat))
	   (have-more (eq? (length testsdat) limit)))
      (if have-more 
	  (let ((new-offset (+ offset limit)))
	    (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
	    (loop (db:get-tests-for-run dbstruct run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals: qryvals)
		  full-list
		  new-offset
		  limit))
	  full-list))))

(define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
  (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode))

(define (mt:get-run-stats)
  (cdb:remote-run db:get-run-stats #f))

(define (mt:discard-blocked-tests run-id failed-test tests test-records)
  (if (null? tests)
      tests
      (begin
	(debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test)
	(let loop ((testn (car tests))
		   (remt  (cdr tests))
		   (res   '()))
	  (let ((waitons (vector-ref (hash-table-ref/default test-records testn (vector #f #f '())) 2)))
	    ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
	    (if (null? remt)
		(let ((new-res (reverse res)))
		  ;; (print "       new-res: " new-res)
		  new-res)
		(loop (car remt)
		      (cdr remt)
		      (if (member failed-test waitons)
			  res
			  (cons testn res)))))))))

;;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:process-triggers test-id newstate newstatus)
  (let* ((test-dat      (mt:lazy-get-test-info-by-id test-id))

      (cdr reg)
      (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
	  '()
	  reg)))

(define runs:nothing-left-in-queue-count 0)

(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode))
	 (fails           (runs:calc-fails prereqs-not-met))
	 (non-completed   (runs:calc-not-completed prereqs-not-met)))
    (debug:print-info 4 "START OF INNER COND #2 "
		      "\n can-run-more:    " can-run-more
		      "\n testname:        " hed

	;; We need to use this to dequeue this item as CANNOTRUN
	(for-each (lambda (prereq)
		    (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN)
			(set! give-up #t)))
		  prereqstrs)
	(if (and give-up
		 (not (and (null? tal)(null? reg))))
	    (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
		  (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
	      (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue")
	      (if (and (null? trimmed-tal)
		       (null? trimmed-reg))
		  #f
		  (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
			reruns)))
	      (list (car newtal)(append (cdr newtal) reg) '() reruns))))


     ;; (debug:print-info 1 "allinqueue: " allinqueue)
     ;; (debug:print-info 1 "prereqstrs: " prereqstrs)
     ;; (debug:print-info 1 "notinqueue: " notinqueue)
     ;; (debug:print-info 1 "tal:        " tal)
     ;; (debug:print-info 1 "newtal:     " newtal)
     ;; (debug:print-info 1 "reg:        " reg)

	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
	  (let ((can-run-more    (runs:can-run-more-tests jobgroup max-concurrent-jobs)))
	    (if (and (list? can-run-more)
		     (car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records)))
		  (if loop-list
		      (apply loop loop-list)))
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))
	    
	 ;; this case should not happen, added to help catch any bugs
	 ((and (list? items) itemdat)

#
# run some tests

BINPATH=$(shell readlink -m $(PWD)/../bin)
MEGATEST=$(BINPATH)/megatest
PATH := $(BINPATH):$(PATH)
RUNNAME := $(shell date +w%V.%u.%H.%M)
IPADDR := "-"

test8 : test8a
	cd fullrun;$(MEGATEST) -runtests lineitem_fail 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singletest
	cd fullrun;$(MEGATEST) -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem
	cd fullrun;$(MEGATEST) -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton

# Some simple checks for bootstrapping and run loop logic 

test9 : minsetup test9a test9b test9c test9d test9e

test9a :
	@echo Run super-simple mintest e, no waitons.
	cd mintest;megatest -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9b :
	@echo Run simple mintest d with one waiton c
	cd mintest;megatest -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9c :
	@echo Run mintest a with full waiton chain a -> b -> c -> d -> e
	cd mintest;megatest -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9d :
	@echo Run an itemized test with no items
	cd mintest;megatest -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9e :
	@echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1
	cd mintest;megatest -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test10 :
	@echo Run a bunch of different targets simultaneously
	(cd fullrun;$(MEGATEST) -server - ;sleep 2)&
	for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \
	   (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done
	for sys in ubuntu suse redhat debian;do \
	  for fs in afs nfs zfs; do \

# Add steps here. Format is "stepname script"
[ezsteps]
step1 echo SUCCESS

[requirements]
waiton b1

# Add steps here. Format is "stepname script"
[ezsteps]
step1 echo SUCCESS

[requirements]
waiton c1

# Add steps here. Format is "stepname script"
[ezsteps]
step1 echo SUCCESS

[requirements]
waiton d1fail

# Add steps here. Format is "stepname script"
[ezsteps]
step1 echo SUCCESS
step2 exit 123

[requirements]
waiton e1

# Add steps here. Format is "stepname script"
[ezsteps]
step1 echo SUCCESS