Megatest

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

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

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

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

(declare (unit db))

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

  (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)
		   (open-db)))
	 (res #f))
    (set! res (apply proc db params))
    (if (not idb)(sqlite3:finalize! db))
    (debug:print-info 11 "open-run-close-no-exception-handling END" )
    res))


(define (open-run-close-exception-handling proc idb . params)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "EXCEPTION: database probably overloaded?")
     (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)))

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

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

	 (run-ids      (db:get-run-ids db))) ;; iterate over runs to divy up the calls
    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
    (for-each
     (lambda (run-id)

       ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
       ;;







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

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










;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs dbstruct runpatt count offset keypatts)

		       (wildtype (if (substring-index "%" patt) "like" "glob")))
		  (if patt
		      (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
		      (begin
			(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
			(exit 6)))))
	      keyvals)
    (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time"
			(if limit  (conc " LIMIT " limit)   "")
			(if offset (conc " OFFSET " offset) "")
			";"))
    (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
    (sqlite3:for-each-row 
     (lambda (a . r)
       (set! res (cons (list->vector (cons a r)) res)))
     (db:get-db dbstruct #f)
     qry-str
     runnamepatt)
    (vector header res)))

;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
(define (db:get-run-info dbstruct run-id)
  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
  ;;    (hash-table-ref *run-info-cache* run-id)
  (let* ((res      #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

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

;;  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) 
			      #f
			      (conc " state "  
				    (if not-in
					" NOT IN ('"

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

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

			       (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))))
  (db:process-triggers test-id newstate newstatus)
  #t)) ;; retrun something to keep the remote calls happy

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

     (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)
		      (if (directory-exists? p)
			  (glob (conc p "/" fnamepatt))
			  '()))
		    paths-from-db))

     (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

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

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

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

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



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

;; 	      ;; (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))
;;   (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* 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)

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

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

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

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

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

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

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