Megatest

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

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

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

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

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

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

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

  configinfo
  configdat
  denoise
  client-signature
  remote
  )

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

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

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

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

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

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

;;     (client:launch))

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

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

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

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

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

;; (define (db:get-path dbstruct id)
;;   (let ((fdb (db:get-filedb dbstruct)))
;;     (filedb:get-path db id)))

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

;; open an sql database inside a file lock
;;
;; returns: db existed-prior-to-opening
;;
(define (db:lock-create-open fname initproc)

	      (begin
		(dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ...
		db)
	      (begin
		(dbr:dbstruct-set-inmem!  dbstruct inmem)
		;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders
		;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context
		(db:sync-tables db:sync-tests-only db inmem)
		(db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? 
		(db:sync-tables area-dat db:sync-tests-only db inmem)
		(db:delay-if-busy refdb area-dat) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? 
		(dbr:dbstruct-set-refdb!  dbstruct refdb)
		(db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
		(db:sync-tables area-dat db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
		;; sync once more to deal with delays?
		;; (db:sync-tables db:sync-tests-only db inmem)
		;; (db:sync-tables db:sync-tests-only inmem refdb)
		inmem))))))

;; This routine creates the db. It is only called if the db is not already ls opened
;;

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

(define (db:close-main dbstruct)

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

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

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

  (let* ((toppath  (launch:setup-for-run))
	 (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	 (mtdb     (if toppath (db:open-megatest-db)))
	 (allow-cleanup (if run-ids #f #t))
	 (run-ids  (if run-ids 
		       run-ids
		       (if toppath (begin
				     (db:delay-if-busy mtdb)
				     (db:delay-if-busy mtdb area-dat)
				     (db:get-all-run-ids mtdb)))))
	 (tdbdat  (tasks:open-db))
	 (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))))
	 (servers (tasks:get-all-servers (db:delay-if-busy tdbdat area-dat))))
    
    ;; kill servers
    (if (member 'killservers options)
	(for-each
	 (lambda (server)
	   (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration")
	   (tasks:server-delete-record (db:delay-if-busy tdbdat area-dat) (vector-ref server 0) "dbmigration")
	   (tasks:kill-server (vector-ref server 2)(vector-ref server 1)))
	 servers))

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

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

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

	     (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
		    (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
	       ;; (db:delay-if-busy frundb)
	       ;; (db:delay-if-busy mtdb)
	       ;; (db:clean-up frundb)
	       (if (eq? run-id 0)
		   (begin
		     (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb)
		     (db:sync-tables area-dat (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb)
		     (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))))
		   (begin
		     ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db
		     (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)
		     (db:sync-tables area-dat db:sync-tests-only (db:get-db fromdb run-id) mtdb)
		     (db:clean-up-rundb (db:get-db fromdb run-id))
		     ))))
	   all-run-ids)
	  ;; removed deleted runs
	  (let ((dbdir (tasks:get-task-db-path)))
	    (for-each (lambda (run-id)
			(let ((fullname (conc dbdir "/" run-id ".db")))

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

(define (db:initialize-main-db dbdat)
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
(define (db:initialize-main-db dbdat area-dat)
  (let* ((configdat (megatest:area-configdat area-dat)) ;; (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys))
	 (db       (db:dbdat-get-db dbdat)))
    (for-each (lambda (key)
		(let ((keyn key))

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

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

(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
(define (db:have-incompletes? dbstruct run-id ovr-deadtime area-dat)
  (let* ((dbdat        (db:get-db dbstruct run-id))
	 (db           (db:dbdat-get-db dbdat))
	 (incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime-str (configf:lookup (megatest:area-configdat area-dat) "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200))) ;; two hours
    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
    
    ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
    ;;
    ;; HOWEVER: this code in run:test seems to work fine
    ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
    ;;                     (db:test-get-run_duration testdat)))
    ;;                    600) 
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat) 
    (sqlite3:for-each-row 
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (begin
	     (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	     (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
	   (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
     db
     "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
     run-id deadtime)

    ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
    ;;
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	   (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))

	#t)))

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

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime area-dat)
  (let* ((dbdat        (db:get-db dbstruct run-id))
	 (db           (db:dbdat-get-db dbdat))
	 (incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime-str (configf:lookup (megatest:area-configdat area-dat) "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200))) ;; two hours
    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
    
    ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
    ;;
    ;; HOWEVER: this code in run:test seems to work fine
    ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
    ;;                     (db:test-get-run_duration testdat)))
    ;;                    600) 
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row 
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (begin
	     (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	     (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
	   (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
     db
     "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
     run-id deadtime)

    ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
    ;;
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	   (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
     db
     "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
     run-id)
    
    (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")

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

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

	       ;; delete all tests that have no run
	       "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);"
	       ;; delete all runs that are state='deleted'
	       "DELETE FROM runs WHERE state='deleted';"
	       ;; delete empty runs
	       "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);"
	       ))))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count before clean: " tot))
			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    ;; (db:find-and-mark-incomplete db)
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:execute db "VACUUM;")))

;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:

		(sqlite3:prepare db stmt))
	      (list
	       ;; delete all tests that belong to runs that are 'deleted'
	       ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
	       ;; delete all tests that are 'DELETED'
	       "DELETE FROM tests WHERE state='DELETED';"
	       ))))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count before clean: " tot))
			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    ;; (db:find-and-mark-incomplete db)
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:execute db "VACUUM;")))

;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:

		)))
	 (dead-runs '()))
    (sqlite3:for-each-row
     (lambda (run-id)
       (set! dead-runs (cons run-id dead-runs)))
       db
       "SELECT id FROM runs WHERE state='deleted';")
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count before clean: " tot))
			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    ;; (db:find-and-mark-incomplete db)
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:execute db "VACUUM;")
    dead-runs))

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

;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
;; Operates on megatestdb
;;
(define (db:get-var dbstruct var)
(define (db:get-var dbstruct var area-dat)
  (let* ((start-ms (current-milliseconds))
         (throttle (let ((t  (config-lookup *configdat* "setup" "throttle")))
         (throttle (let ((t  (config-lookup (megatest:area-configdat area-dat) "setup" "throttle")))
		     (if t (string->number t) t)))
	 (res      #f)
	 (dbdat    (db:get-db dbstruct #f))
	 (db       (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     db
     "SELECT val FROM metadat WHERE var=?;" var)
    ;; convert to number if can
    (if (string? res)

	  (debug:print-info 4 "launch throttle factor=" *global-delta*)
	  (set! *last-global-delta-printed* *global-delta*)))
    res))

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

(define (db:del-var dbstruct var)
  ;; (db:delay-if-busy)
  (db:with-db dbstruct #f #t 
	      (lambda (db)
		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))

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

;; replace header and keystr with a call to runs:get-std-run-fields

  (let* ((dbdat        (db:get-db dbstruct #f))
	 (db           (db:dbdat-get-db dbdat))
	 (totals       (make-hash-table))
	 (curr         (make-hash-table))
	 (res          '())
	 (runs-info    '()))
    ;; First get all the runname/run-ids
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (run-id runname)
       (set! runs-info (cons (list run-id runname) runs-info)))
     db
     "SELECT id,runname FROM runs WHERE state != 'deleted';")
    ;; for each run get stats data
    (for-each

	 (res       (vector #f #f #f #f))
	 (keys      (db:get-keys dbstruct))
	 (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
	 (header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (a . x)
       (set! res (apply vector a x)))
     db 
     (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
     run-id)
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)

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

(define (db:update-run-event_time dbstruct run-id)
  (db:with-db
   dbstruct
   #f
   #t

       (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
			user (conc newlockval " " run-id))
       (debug:print-info 1 "" newlockval " run number " run-id)))))

(define (db:set-run-status dbstruct run-id status msg)
  (let* ((dbdat (db:get-db dbstruct #f))
	 (db    (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (if msg
	(sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
	(sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))

(define (db:get-run-status dbstruct run-id)
  (let ((res "n/a"))
    (db:with-db

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

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

(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
  (let* ((dbdat (db:get-db dbstruct #f))
	 (db    (db:dbdat-get-db dbdat)))
  (if (not jobgroup)
      0 ;; 
      (let ((testnames '()))
	;; get the testnames
	(db:delay-if-busy dbdat)
	(db:delay-if-busy dbdat area-dat)
	(sqlite3:for-each-row
	 (lambda (testname)
	   (set! testnames (cons testname testnames)))
	 db
	 "SELECT testname FROM test_meta WHERE jobgroup=?"
	 jobgroup)
	;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?

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

;;    if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;;    if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup dbstruct run-id test-id status)
  (let* ((dbdat      (db:get-db dbstruct run-id))
	 (db         (db:dbdat-get-db dbdat))
	 (fail-count 0)
	 (pass-count 0))
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (fcount pcount)
       (set! fail-count fcount)
       (set! pass-count pcount))
     db 
     "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
             (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"

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

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

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

;; get the previous records for when these tests were run where all keys match but runname
;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
;; can use wildcards. Also can likely be factored in with get test paths?
;;
;; Run this remotely!!
;;
(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
  (let* ((dbdat   (db:get-db dbstruct #f))
	 (db      (db:dbdat-get-db dbdat))
	 (keys    (db:get-keys db))
	 (selstr  (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
	 (qrystr  (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
	 (keyvals #f)
	 (tests-hash (make-hash-table)))
    ;; first look up the key values from the run selected by run-id
    (db:delay-if-busy dbdat)
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row 
     (lambda (a . b)
       (set! keyvals (cons a b)))
     db
     (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
    (if (not keyvals)
	'()

			   ;; this test is younger, store it in the hash
			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

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

(define (db:test-get-records-for-index-file dbstruct run-id test-name)

;; 
;; A single data structure for all the data used in a dashboard for
;; a given area.
;;
;; Share this structure between newdashboard and dashboard with the 
;; intent of converging on a single app.
;;
;; (define *data* (make-vector 25 #f))
(define *data* (make-vector 25 #f))
(define (dboard:data-get-runs          vec)    (vector-ref  vec 0))
(define (dboard:data-get-tests         vec)    (vector-ref  vec 1))
(define (dboard:data-get-runs-matrix   vec)    (vector-ref  vec 2))
(define (dboard:data-get-tests-tree    vec)    (vector-ref  vec 3))
(define (dboard:data-get-run-keys      vec)    (vector-ref  vec 4))
(define (dboard:data-get-curr-test-ids vec)    (vector-ref  vec 5))
;; (define (dboard:data-get-test-details  vec)    (vector-ref  vec 6))

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

			    (begin
			      (thread-sleep! 2)
			      (processloop (+ i 1)))))
	    (debug:print-info 0 "logpro for step " stepname " exited with code " (vector-ref exit-info 2)))))
    
    (let ((exinfo (vector-ref exit-info 2))
	  (logfna (if logpro-used (conc stepname ".html") "")))
      (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
      (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna area-dat))
    (if logpro-used
	(rmt:test-set-log! run-id test-id (conc stepname ".html")))
	(rmt:test-set-log! run-id test-id (conc stepname ".html") area-dat))
    ;; set the test final status
    (let* ((this-step-status (cond
			      ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
			      ((eq? (vector-ref exit-info 2) 0)                   'pass)
			      (else 'fail)))
	   (overall-status   (cond
			      ((eq? (vector-ref exit-info 3) 2) 'warn) ;; rollup-status

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

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

	  (change-directory top-path)

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

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

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

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

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

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

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

    ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical
    ;;                                                 rundir   shortdir
    (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path)
    (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path area-dat)

    (debug:print 2 "INFO:\n       lnkbase=" lnkbase "\n       lnkpath=" lnkpath "\n  toptest-path=" toptest-path "\n     test-path=" test-path)
    (if (not (file-exists? linktree))
	(begin
	  (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
	  (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
    ;; create the directory for the tests dir links, this is needed no matter what...

    ;; NB - This was not working right - some top tests are not getting the path set!!!
    ;;
    ;; Do the setting of this record after the paths are created so that the shortdir can 
    ;; be set to the real directory location. This is safer for future clean up if the link
    ;; tree is damaged or lost.
    ;; 
    (if (not (hash-table-ref/default *toptest-paths* testname #f))
	(let* ((testinfo       (rmt:get-test-info-by-id run-id test-id)) ;;  run-id testname item-path))
	(let* ((testinfo       (rmt:get-test-info-by-id run-id test-id area-dat)) ;;  run-id testname item-path))
	       (curr-test-path (if testinfo ;; (filedb:get-path *fdb*
							     ;; (db:get-path dbstruct
				   ;; (rmt:sdb-qry 'getstr 
				   (db:test-get-rundir testinfo) ;; ) ;; )
				   #f)))
	  (hash-table-set! *toptest-paths* testname curr-test-path)
	  ;; NB// Was this for the test or for the parent in an iterated test?
	  (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath 
			    (if (file-exists? lnkpath)
				(resolve-pathname lnkpath)
				lnkpath)
			    testname "")
			    testname "" area-dat)
	  ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path)
	  (if (or (not curr-test-path)
		  (not (directory-exists? toptest-path)))
	      (begin
		(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
		(handle-exceptions
		 exn

	 (work-area  #f)
	 (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
	 (diskpath   #f)
	 (cmdparms   #f)
	 (fullcmd    #f) ;; (define a (with-output-to-string (lambda ()(write x))))
	 (mt-bindir-path #f)
	 ;; (test-id    (cdb:remote-run db:get-test-id #f run-id test-name item-path))
	 (testinfo   (rmt:get-test-info-by-id run-id test-id))
	 (testinfo   (rmt:get-test-info-by-id run-id test-id area-dat))
	 (mt_target  (string-intersperse (map cadr keyvals) "/"))
	 (debug-param (append (if (args:get-arg "-debug")  (list "-debug" (args:get-arg "-debug")) '())
			      (if (args:get-arg "-logging")(list "-logging") '()))))
    (setenv "MT_ITEMPATH" item-path)
    (if hosts (set! hosts (string-split hosts)))
    ;; set the megatest to be called on the remote host
    (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
    (set! mt-bindir-path (pathname-directory remote-megatest))
    (if launcher (set! launcher (string-split launcher)))
    ;; set up the run work area for this test
    (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
	     (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir
	(begin
	  (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
	  (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record
    
    ;; prevent overlapping actions - set to LAUNCHED as early as possible
    ;;
    (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
    (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED")
    (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED" area-dat)
    (set! diskpath (get-best-disk configdat))
    (if diskpath
	(let ((dat  (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
	  (set! work-area (car dat))
	  (set! toptest-work-area (cadr dat))
	  (debug:print-info 2 "Using work area " work-area))
	(begin

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

;; (include "common.scm")
;; (include "megatest-version.scm")

;; fakeout readline
(define (toplevel-command . a) #f)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras)
     http-client srfi-18 extras format) ;;  zmq extras)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

		    #f                ;; configinfo
		    #f                ;; configdat
		    (make-hash-table) ;; denoise
		    #f                ;; client signature
		    #f                ;; remote connections
		    ))

(define *runremote* #f) ;; BUG: Remove this ASAP and update common:*remote* to not refer to *runremote*

;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest

      (set! *didsomething* #t)))))
	  
(if (args:get-arg "-remove-runs")
    (general-run-call 
     "-remove-runs"
     "remove runs"
     (lambda (target runname keys keyvals)
       (operate-on 'remove-runs))))
       (operate-on 'remove-runs))
     *area-dat*))

(if (args:get-arg "-set-state-status")
    (general-run-call 
     "-set-state-status"
     "set state and status"
     (lambda (target runname keys keyvals)
       (operate-on 'set-state-status))))
       (operate-on 'set-state-status))
     *area-dat*))

(if (or (args:get-arg "-set-run-status")
	(args:get-arg "-get-run-status"))
    (general-run-call
     "-set-run-status"
     "set run status"
     (lambda (target runname keys keyvals)

	       (debug:print-info 0 "No matching run found.")
	       (exit 1))
	     (let* ((row      (car (vector-ref runsdat 1)))
		    (run-id   (db:get-value-by-header row header "id")))
	       (if (args:get-arg "-set-run-status")
		   (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
		   (print (rmt:get-run-status run-id))
		   )))))))
		   )))))
     *area-dat*))

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

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;

     "-runall"
     "run all tests"
     (lambda (target runname keys keyvals)
       (runs:run-tests target
		       runname
		       (args:get-arg "-testpatt")
		       user
		       args:arg-hash))))
		       args:arg-hash
		       *area-dat*))
     *area-dat*))

;;======================================================================
;; run one test
;;======================================================================

;; 1. find the config file
;; 2. change to the test directory

     ;;    	     runname
     ;;    	     (args:get-arg "-runtests")
     ;;    	     #f))))
     (runs:run-tests target
		     runname
		     (args:get-arg "-runtests")
		     user
		     args:arg-hash))))
		     args:arg-hash
		     *area-dat*))
   *area-dat*))

;;======================================================================
;; Rollup into a run
;;======================================================================

(if (args:get-arg "-rollup")
    (general-run-call 
     "-rollup" 
     "rollup tests" 
     (lambda (target runname keys keyvals)
       (runs:rollup-run keys
			keyvals
			(or (args:get-arg "-runname")(args:get-arg ":runname") )
			user))))
			user))
     *area-dat*))

;;======================================================================
;; Lock or unlock a run
;;======================================================================

(if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
    (general-run-call 
     (if (args:get-arg "-lock") "-lock" "-unlock")
     "lock/unlock tests" 
     (lambda (target runname keys keyvals)
       (runs:handle-locking 
		  target
		  keys
		  (or (args:get-arg "-runname")(args:get-arg ":runname") )
		  (args:get-arg "-lock")
		  (args:get-arg "-unlock")
		  user))))
		  user))
     *area-dat*))

;;======================================================================
;; Get paths to tests
;;======================================================================
;; Get test paths matching target, runname, and testpatt
(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
    ;; if we are in a test use the MT_CMDINFO data

	 "Get paths to test"
	 (lambda (target runname keys keyvals)
	   (let* ((db       #f)
		  ;; DO NOT run remote
		  (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))
		       paths)))
	*area-dat*)))

;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (args:get-arg "-archive")
    ;; else do a general-run-call
    (general-run-call 
     "-archive"
     "Archive"
     (lambda (target runname keys keyvals)
       (operate-on 'archive))))
       (operate-on 'archive))
     *area-dat*))

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

(if (args:get-arg "-extract-ods")
    (general-run-call
     "-extract-ods"
     "Make ods spreadsheet"
     (lambda (target runname keys keyvals)
       (let ((dbstruct   (make-dbr:dbstruct path: *toppath* local: #t))
	     (outputfile (args:get-arg "-extract-ods"))
	     (runspatt   (or (args:get-arg "-runname")(args:get-arg ":runname")))
	     (pathmod    (args:get-arg "-pathmod")))
	     ;; (keyvalalist (keys->alist keys "%")))
	 (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
	 (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
	 (db:close-all dbstruct)
	 (set! *didsomething* #t)))))
	 (set! *didsomething* #t)))
     *area-dat*))

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

      (open-run-close runs:update-all-test_meta #f)
      (set! *didsomething* #t)))

;;======================================================================
;; Start a repl
;;======================================================================

;; fakeout readline
(define (toplevel-command . a) #f)

(if (or (args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup-for-run *area-dat*))
	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
      (if dbstruct
	  (begin
	    (set! *db* dbstruct)
	    (set! *client-non-blocking-mode* #t)
	    (import extras) ;; might not be needed
	    ;; (import csi)
	    (import readline)
            (use-legacy-bindings)
	    (import apropos)
	    ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
	    (gnu-history-install-file-manager
	     (string-append
	      (or (get-environment-variable "HOME") ".") "/.megatest_history"))
	     (let ((d (string-append
		       (or (get-environment-variable "HOME") ".") "/.megatest")))
	       (if (not (file-exists? d))
		   (create-directory d #t))
	       d))
	    (current-input-port (make-gnu-readline-port "megatest> "))
	    (if (args:get-arg "-repl")
		(repl)
		(load (args:get-arg "-load")))
	    (db:close-all dbstruct))
	  (exit))
      (set! *didsomething* #t)))

;;======================================================================
;; Exit and clean up
;;======================================================================

;; if *runremote* is defined, close connections, otherwise - trust that it was
;; taken care of.
;;
(if (common:get-remote (megatest:area-remote *area-dat*) #f)
(if (common:get-remote #f #f)(close-all-connections!))
    (close-all-connections!))

(if (not *didsomething*)
    (debug:print 0 help))

(set! *time-to-exit* #t)
(thread-join! *watchdog*)

	       (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second)
	       #t)
	     #f))))

;; if a server is either running or in the process of starting call client:setup
;; else return #f to let the calling proc know that there is no server available
;;
(define (rmt:get-connection-info run-id #!key (remote #f))
(define (rmt:get-connection-info run-id area-dat #!key (remote #f))
  (let ((cinfo (common:get-remote remote run-id)))
    (if cinfo
	cinfo
	;; NB// can cache the answer for server running for 10 seconds ...
	;;  ;; (and (not (rmt:write-frequency-over-limit? cmd run-id))
	(if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)
	    (client:setup run-id remote: remote)
	    #f))))

(define (rmt:discard-old-connections)
(define (rmt:discard-old-connections area-dat)
  ;; clean out old connections
  (mutex-lock! *db-multi-sync-mutex*)
  (let ((remote      (megatest:area-remote area-dat))
  (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin
	(expire-time (- (current-seconds) (server:get-timeout area-dat) 10))) ;; don't forget the 10 second margin
    (for-each 
     (lambda (run-id)
       (let ((connection (common:get-remote remote run-id)))
         (if (and (vector? connection)
        	  (< (http-transport:server-dat-get-last-access connection) expire-time))
             (begin
               (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses")
               ;; SHOULD CLOSE THE CONNECTION HERE
	       (case *transport-type*
		 ((nmsg)(nn-close (http-transport:server-dat-get-socket 
				   (common:get-remote remote run-id)))))
               (common:del-remote! remote run-id)))))
     (common:get-remote-all remote)))
  (mutex-unlock! *db-multi-sync-mutex*))

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(remote #f)) ;; start attemptnum at 1 so the modulo below works as expected
  (rmt:discard-old-connections)
(define (rmt:send-receive cmd rid params area-dat #!key (attemptnum 1)(remote #f)) ;; start attemptnum at 1 so the modulo below works as expected
  (rmt:discard-old-connections area-dat)
  ;; (mutex-lock! *send-receive-mutex*)
  (let* ((run-id          (if rid rid 0))
	 (connection-info (rmt:get-connection-info run-id)))
	 (connection-info (rmt:get-connection-info run-id area-dat)))
    ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also)
    (if connection-info
	;; use the server if have connection info
	(let* ((dat     (case *transport-type*
			  ((http)(condition-case
				  (http-transport:client-api-send-receive run-id connection-info cmd params)
				  ((commfail)(vector #f "communications fail"))

		;; (nmsg-transport:client-api-send-receive run-id connection-info cmd param remtries: (- remtries 1))))))

		;; no longer killing the server in http-transport:client-api-send-receive
		;; may kill it here but what are the criteria?
		;; start with three calls then kill server
		;; (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id))
		;; (thread-sleep! 2)
		(rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1)))))
		(rmt:send-receive cmd run-id params area-dat attemptnum: (+ attemptnum 1)))))
	;; no connection info? try to start a server, or access locally if no
	;; server and the query is read-only
	;;
	;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call
	;;
	(if (and (< attemptnum 15)
		 (member cmd api:write-queries))
	    (let ((faststart (configf:lookup *configdat* "server" "faststart")))
	      (common:del-remote! remote run-id)
	      ;; (mutex-unlock! *send-receive-mutex*)
	      (if (and faststart (equal? faststart "no"))
		  (begin
		    (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10)
		    (thread-sleep! (random 5)) ;; give some time to settle and minimize collison?
		    (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
		    (rmt:send-receive cmd rid params area-dat attemptnum: (+ attemptnum 1)))
		  (begin
		    (server:kind-run run-id)
		    (rmt:open-qry-close-locally cmd run-id params))))
		    (server:kind-run run-id area-dat)
		    (rmt:open-qry-close-locally cmd run-id params area-dat))))
	    (begin
	      ;; (debug:print 0 "ERROR: Communication failed!")
	      ;; (mutex-unlock! *send-receive-mutex*)
	      ;; (exit)
	      (rmt:open-qry-close-locally cmd run-id params)
	      (rmt:open-qry-close-locally cmd run-id params area-dat)
	      )))))

(define (rmt:update-db-stats run-id rawcmd params duration)
  (mutex-lock! *db-stats-mutex*)
  (handle-exceptions
   exn
   (begin

		(mutex-lock! *db-multi-sync-mutex*)
		;; (if (not (hash-table-ref/default *db-local-sync* run-id #f))
		;; just set it every time. Is a write more expensive than a read and does it matter?
		(hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write"
		(mutex-unlock! *db-multi-sync-mutex*)))
	  res))))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params area-dat)
  (let* ((run-id   (if run-id run-id 0))
	 ;; (jparams  (db:obj->string params)) ;; (rmt:dat->json-str params))
	 (res  	   (handle-exceptions
		    exn
		    #f
		    (http-transport:client-api-send-receive run-id connection-info cmd params))))
;;		    ((commfail) (vector #f "communications fail")))))

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

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

(define (rmt:kill-server run-id)
  (rmt:send-receive 'kill-server run-id (list run-id)))
  (rmt:send-receive 'kill-server run-id (list run-id) area-dat))

(define (rmt:start-server run-id)
  (rmt:send-receive 'start-server 0 (list run-id)))
  (rmt:send-receive 'start-server 0 (list run-id) area-dat))

;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
  (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info run-id)
  (case *transport-type*
    ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
    ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))))
    ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat))
    ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*) area-dat))))

;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible 
;;
(define (rmt:general-call stmtname run-id . params)
  (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
(define (rmt:general-call stmtname run-id area-dat . params)
  (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params) area-dat))

(define (rmt:sync-inmem->db run-id)
  (rmt:send-receive 'sync-inmem->db run-id '()))
(define (rmt:sync-inmem->db run-id area-dat)
  (rmt:send-receive 'sync-inmem->db run-id '() area-dat))

(define (rmt:sdb-qry qry val run-id)
(define (rmt:sdb-qry qry val run-id area-dat)
  ;; add caching if qry is 'getid or 'getstr
  (rmt:send-receive 'sdb-qry run-id (list qry val)))
  (rmt:send-receive 'sdb-qry run-id (list qry val) area-dat))

;; NOT COMPLETED
(define (rmt:runtests user run-id testpatt params)
  (rmt:send-receive 'runtests run-id testpatt))
(define (rmt:runtests user run-id testpatt params area-dat)
  (rmt:send-receive 'runtests run-id testpatt area-dat))

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

;; These require run-id because the values come from the run!
;;
(define (rmt:get-key-val-pairs run-id)
  (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
(define (rmt:get-key-val-pairs run-id area-dat)
  (rmt:send-receive 'get-key-val-pairs run-id (list run-id) area-dat))

(define (rmt:get-keys)
  (rmt:send-receive 'get-keys #f '()))
(define (rmt:get-keys area-dat)
  (rmt:send-receive 'get-keys #f '() area-dat))

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

(define (rmt:get-test-id run-id testname item-path)
  (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
(define (rmt:get-test-id run-id testname item-path area-dat)
  (rmt:send-receive 'get-test-id run-id (list run-id testname item-path) area-dat))

(define (rmt:get-test-info-by-id run-id test-id)
(define (rmt:get-test-info-by-id run-id test-id area-dat)
  (if (and (number? run-id)(number? test-id))
      (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
      (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id) area-dat)
      (begin
	(debug:print 0 "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
	(print-call-chain (current-error-port))
	#f)))

(define (rmt:test-get-rundir-from-test-id run-id test-id)
  (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
(define (rmt:test-get-rundir-from-test-id run-id test-id area-dat)
  (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id) area-dat))

(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
(define (rmt:open-test-db-by-test-id run-id test-id area-dat #!key (work-area #f))
  (let* ((test-path (if (string? work-area)
			work-area
			(rmt:test-get-rundir-from-test-id run-id test-id))))
			(rmt:test-get-rundir-from-test-id run-id test-id area-dat))))
    (debug:print 3 "TEST PATH: " test-path)
    (open-test-db test-path)))

;; WARNING: This currently bypasses the transaction wrapped writes system
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
  (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment area-dat)
  (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment) area-dat))

(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
  (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus area-dat)
  (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus) area-dat))

(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals area-dat)
  (if (number? run-id)
      (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))
      (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) area-dat)
      (begin
	(debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id)
	(print-call-chain (current-error-port))
	'())))

;; get stuff via synchash 
(define (rmt:synchash-get run-id proc synckey keynum params)
  (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
(define (rmt:synchash-get run-id proc synckey keynum params area-dat)
  (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params) area-dat))

;; IDEA: Threadify these - they spend a lot of time waiting ...
;;
(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in area-dat)
  (let ((multi-run-mutex (make-mutex))
	(run-id-list (if run-ids
			 run-ids
			 (rmt:get-all-run-ids)))
	(result      '()))
    (if (null? run-id-list)
	'()
	(let loop ((hed     (car run-id-list))
		   (tal     (cdr run-id-list))
		   (threads '()))
	  (if (> (length threads) 5)
	      (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads))
	      (let* ((newthread (make-thread
				 (lambda ()
				   (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in))))
				   (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in) area-dat)))
				     (if (list? res)
					 (begin
					   (mutex-lock! multi-run-mutex)
					   (set! result (append result res))
					   (mutex-unlock! multi-run-mutex))
					 (debug:print 0 "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
				 (conc "multi-run-thread for run-id " hed)))

;;   (let ((run-id-list (if run-ids
;; 			 run-ids
;; 			 (rmt:get-all-run-ids))))
;;     (apply append (map (lambda (run-id)
;; 			 (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in)))
;; 		       run-id-list))))

(define (rmt:delete-test-records run-id test-id)
  (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
(define (rmt:delete-test-records run-id test-id area-dat)
  (rmt:send-receive 'delete-test-records run-id (list run-id test-id) area-dat))

;; This is not needed as test steps are deleted on test delete call
;;
;; (define (rmt:delete-test-step-records run-id test-id)
;;   (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id)))

(define (rmt:test-set-status-state run-id test-id status state msg)
  (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg)))
(define (rmt:test-set-status-state run-id test-id status state msg area-dat)
  (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg) area-dat))

(define (rmt:test-toplevel-num-items run-id test-name)
  (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name)))
(define (rmt:test-toplevel-num-items run-id test-name area-dat)
  (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name) area-dat))

;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
;;   (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))

(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
  (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
(define (rmt:get-matching-previous-test-run-records run-id test-name item-path area-dat)
  (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path) area-dat))

(define (rmt:test-get-logfile-info run-id test-name)
  (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
(define (rmt:test-get-logfile-info run-id test-name area-dat)
  (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name) area-dat))

(define (rmt:test-get-records-for-index-file run-id test-name)
  (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
(define (rmt:test-get-records-for-index-file run-id test-name area-dat)
  (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name) area-dat))

(define (rmt:get-testinfo-state-status run-id test-id)
  (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
(define (rmt:get-testinfo-state-status run-id test-id area-dat)
  (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id) area-dat))

(define (rmt:test-set-log! run-id test-id logf)
  (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
(define (rmt:test-set-log! run-id test-id logf area-dat)
  (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id area-dat)))

(define (rmt:test-set-top-process-pid run-id test-id pid)
  (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid)))
(define (rmt:test-set-top-process-pid run-id test-id pid area-dat)
  (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid) area-dat))

(define (rmt:test-get-top-process-pid run-id test-id)
  (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id)))
(define (rmt:test-get-top-process-pid run-id test-id area-dat)
  (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id) area-dat))

(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
  (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))
(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt area-dat)
  (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt) area-dat))

;; NOTE: This will open and access ALL run databases. 
;;
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
  (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname area-dat)
  (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt area-dat)))
    (apply append 
	   (map (lambda (run-id)
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname) area-dat))
	   run-ids))))

(define (rmt:get-run-ids-matching keynames target res)
  (rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))
(define (rmt:get-run-ids-matching keynames target res area-dat)
  (rmt:send-receive #f 'get-run-ids-matching (list keynames target res) area-dat) area-dat)

(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal)))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode)))
(define (rmt:get-prereqs-not-met run-id waitons ref-item-path area-dat #!key (mode '(normal)))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode) area-dat))

(define (rmt:get-count-tests-running-for-run-id run-id)
  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
(define (rmt:get-count-tests-running-for-run-id run-id area-dat)
  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id) area-dat))

;; Statistical queries

(define (rmt:get-count-tests-running run-id)
  (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
(define (rmt:get-count-tests-running run-id area-dat)
  (rmt:send-receive 'get-count-tests-running run-id (list run-id) area-dat))

(define (rmt:get-count-tests-running-for-testname run-id testname)
  (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))
(define (rmt:get-count-tests-running-for-testname run-id testname area-dat)
  (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname) area-dat))

(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
  (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup area-dat)
  (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup) area-dat))

(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status)
  (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status)))
(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status area-dat)
  (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status) area-dat))

(define (rmt:update-pass-fail-counts run-id test-name)
  (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name)))
(define (rmt:update-pass-fail-counts run-id test-name area-dat)
  (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name) area-dat))

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

(define (rmt:get-run-info run-id)
  (rmt:send-receive 'get-run-info run-id (list run-id)))
(define (rmt:get-run-info run-id area-dat)
  (rmt:send-receive 'get-run-info run-id (list run-id) area-dat))

;; Use the special run-id == #f scenario here since there is no run yet
(define (rmt:register-run keyvals runname state status user)
  (rmt:send-receive 'register-run #f (list keyvals runname state status user)))
(define (rmt:register-run keyvals runname state status user area-dat)
  (rmt:send-receive 'register-run #f (list keyvals runname state status user) area-dat))
    
(define (rmt:get-run-name-from-id run-id)
  (rmt:send-receive 'get-run-name-from-id run-id (list run-id)))
(define (rmt:get-run-name-from-id run-id area-dat)
  (rmt:send-receive 'get-run-name-from-id run-id (list run-id) area-dat))

(define (rmt:delete-run run-id)
  (rmt:send-receive 'delete-run run-id (list run-id)))
(define (rmt:delete-run run-id area-dat)
  (rmt:send-receive 'delete-run run-id (list run-id) area-dat))

(define (rmt:delete-old-deleted-test-records)
  (rmt:send-receive 'delete-old-deleted-test-records #f '()))
(define (rmt:delete-old-deleted-test-records area-dat)
  (rmt:send-receive 'delete-old-deleted-test-records #f '() area-dat))

(define (rmt:get-runs runpatt count offset keypatts)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
(define (rmt:get-runs runpatt count offset keypatts area-dat)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts) area-dat))

(define (rmt:get-runs runpatt count offset keypatts)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
(define (rmt:get-runs runpatt count offset keypatts area-dat)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts) area-dat))

(define (rmt:get-all-run-ids)
  (rmt:send-receive 'get-all-run-ids #f '()))
(define (rmt:get-all-run-ids area-dat)
  (rmt:send-receive 'get-all-run-ids #f '() area-dat))

(define (rmt:get-prev-run-ids run-id)
  (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
(define (rmt:get-prev-run-ids run-id area-dat)
  (rmt:send-receive 'get-prev-run-ids #f (list run-id) area-dat))

(define (rmt:lock/unlock-run run-id lock unlock user)
  (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
(define (rmt:lock/unlock-run run-id lock unlock user area-dat)
  (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user) area-dat))

;; set/get status
(define (rmt:get-run-status run-id)
  (rmt:send-receive 'get-run-status #f (list run-id)))
(define (rmt:get-run-status run-id area-dat)
  (rmt:send-receive 'get-run-status #f (list run-id) area-dat))

(define (rmt:set-run-status run-id run-status #!key (msg #f))
  (rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
(define (rmt:set-run-status run-id run-status area-dat #!key (msg #f))
  (rmt:send-receive 'set-run-status #f (list run-id run-status msg) area-dat))

(define (rmt:update-run-event_time run-id)
  (rmt:send-receive 'update-run-event_time #f (list run-id)))
(define (rmt:update-run-event_time run-id area-dat)
  (rmt:send-receive 'update-run-event_time #f (list run-id) area-dat))

(define (rmt:get-runs-by-patt  keys runnamepatt targpatt offset limit)
  (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit)))
(define (rmt:get-runs-by-patt  keys runnamepatt targpatt offset limit area-dat)
  (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit) area-dat))

(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
  (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
      (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))))
(define (rmt:find-and-mark-incomplete run-id ovr-deadtime area-dat)
  (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime) area-dat)
      (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime) area-dat)))

;;======================================================================
;; M U L T I R U N   Q U E R I E S
;;======================================================================

;; Need to move this to multi-run section and make associated changes
(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
  (let ((run-ids (rmt:get-all-run-ids)))
(define (rmt:find-and-mark-incomplete-all-runs area-dat #!key (ovr-deadtime #f))
  (let ((run-ids (rmt:get-all-run-ids area-dat)))
    (for-each (lambda (run-id)
	       (rmt:find-and-mark-incomplete run-id ovr-deadtime))
	       (rmt:find-and-mark-incomplete run-id ovr-deadtime area-dat))
	     run-ids)))

;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;; 
;; Run this at the client end since we have to connect to multiple run-id dbs
;;
(define (rmt:get-previous-test-run-record run-id test-name item-path)
  (let* ((keyvals (rmt:get-key-val-pairs run-id))
	 (keys    (rmt:get-keys))
(define (rmt:get-previous-test-run-record run-id test-name item-path area-dat)
  (let* ((keyvals (rmt:get-key-val-pairs run-id area-dat))
	 (keys    (rmt:get-keys area-dat))
	 (selstr  (string-intersperse  keys ","))
	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
    (if (not keyvals)
	#f
	(let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
	(let ((prev-run-ids (rmt:get-prev-run-ids run-id area-dat)))
	  ;; for each run starting with the most recent look to see if there is a matching test
	  ;; if found then return that matching test record
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) #f
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
		(let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f area-dat)))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))

;; If not given the work area
;;  1. Do a remote call to get the test path
;;  2. Continue as above
;; 
;;(define (rmt:get-steps-for-test run-id test-id)
;;  (rmt:send-receive 'get-steps-data run-id (list test-id)))

(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile area-dat)
  (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"))
    (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
    (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile) area-dat)))

(define (rmt:get-steps-for-test run-id test-id)
  (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))
(define (rmt:get-steps-for-test run-id test-id area-dat)
  (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id) area-dat))

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

(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) 
  (let ((tdb  (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
(define (rmt:read-test-data run-id test-id categorypatt area-dat #!key (work-area #f)) 
  (let ((tdb  (rmt:open-test-db-by-test-id run-id test-id area-dat work-area: work-area)))
    (if tdb
	(tdb:read-test-data tdb test-id categorypatt)
	(tdb:read-test-data tdb test-id categorypatt area-dat)
	'())))

(define (rmt:testmeta-add-record testname)
  (rmt:send-receive 'testmeta-add-record #f (list testname)))
(define (rmt:testmeta-add-record testname area-dat)
  (rmt:send-receive 'testmeta-add-record #f (list testname) area-dat))

(define (rmt:testmeta-get-record testname)
  (rmt:send-receive 'testmeta-get-record #f (list testname)))
(define (rmt:testmeta-get-record testname area-dat)
  (rmt:send-receive 'testmeta-get-record #f (list testname) area-dat))

(define (rmt:testmeta-update-field test-name fld val)
  (rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))
(define (rmt:testmeta-update-field test-name fld val area-dat)
  (rmt:send-receive 'testmeta-update-field #f (list test-name fld val) area-dat))

(define (rmt:test-data-rollup run-id test-id status)
  (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
(define (rmt:test-data-rollup run-id test-id status area-dat)
  (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status) area-dat))

(define (rmt:csv->test-data run-id test-id csvdata)
  (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
(define (rmt:csv->test-data run-id test-id csvdata area-dat)
  (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata) area-dat))

;;======================================================================
;;  T A S K S
;;======================================================================

(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt)
  (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt)))
(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt area-dat)
  (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt) area-dat))

(define (rmt:tasks-add action owner target runname testpatt params)
  (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))
(define (rmt:tasks-add action owner target runname testpatt params area-dat)
  (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params) area-dat))

(define (rmt:tasks-set-state-given-param-key param-key new-state)
  (rmt:send-receive 'tasks-set-state-given-param-key #f (list  param-key new-state)))
(define (rmt:tasks-set-state-given-param-key param-key new-state area-dat)
  (rmt:send-receive 'tasks-set-state-given-param-key #f (list  param-key new-state) area-dat))

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

(define (rmt:archive-get-allocations  testname itempath dneeded)
  (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))
(define (rmt:archive-get-allocations  testname itempath dneeded area-dat)
  (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded) area-dat))

(define (rmt:archive-register-block-name bdisk-id archive-path)
  (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path)))
(define (rmt:archive-register-block-name bdisk-id archive-path area-dat)
  (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path) area-dat))

(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
  (rmt:send-receive 'archive-allocate-test-to-block #f (list  block-id testsuite-name areakey)))
(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey area-dat)
  (rmt:send-receive 'archive-allocate-test-to-block #f (list  block-id testsuite-name areakey) area-dat))

(define (rmt:archive-register-disk bdisk-name bdisk-path df)
  (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df)))
(define (rmt:archive-register-disk bdisk-name bdisk-path df area-dat)
  (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df) area-dat))

(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
  (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
(define (rmt:test-set-archive-block-id run-id test-id archive-block-id area-dat)
  (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id) area-dat))

(define (rmt:test-get-archive-block-info archive-block-id)
  (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
(define (rmt:test-get-archive-block-info archive-block-id area-dat)
  (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id) area-dat))

(include "test_records.scm")

(define (runs:test-get-full-path test)
  (let* ((testname (db:test-get-testname   test))
	 (itempath (db:test-get-item-path test)))
    (conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))

;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
;;
(define (runs:create-run-record #!key (remote #f))
  (let* ((mconfig      (if *configdat*
		           *configdat*
		           (if (launch:setup-for-run)
		               *configdat*
		               (begin
		                 (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
		                 (exit 1)))))
	  (runrec      (runs:runrec-make-record))
	  (target      (common:args-get-target))
	  (runname     (or (args:get-arg "-runname")
		           (args:get-arg ":runname")))
	  (testpatt    (or (args:get-arg "-testpatt")
		           (args:get-arg "-runtests")))
	  (keys        (keys:config-get-fields mconfig))
	  (keyvals     (keys:target->keyval keys target))
	  (toppath     *toppath*)
	  (envdat      keyvals) ;; initial values start with keyvals
	  (runconfig   #f)
	  (transport   (or (args:get-arg "-transport") 'http))
	  (run-id      #f))
    ;; Set all the environment vars we know so far, start with keys
    (for-each (lambda (keyval)
		(setenv (car keyval)(cadr keyval)))
	      keyvals)
    ;; Set up various and sundry known vars here
    (setenv "MT_RUN_AREA_HOME" toppath)
    (setenv "MT_RUNNAME" runname)
    (setenv "MT_TARGET"  target)
    (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))
    (set! envdat (append 
		  envdat
		  (list (list "MT_RUN_AREA_HOME" toppath)
			(list "MT_RUNNAME"       runname)
			(list "MT_TARGET"        target))))
    ;; Now can read the runconfigs file
    ;; 
    (set! runconfig (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))
    (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f))
	(begin
	  (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
	  (if db (sqlite3:finalize! db))
	  (exit 1)))
    ;; Now have runconfigs data loaded, set environment vars
    (for-each (lambda (section)
		(for-each (lambda (varval)
			    (set! envdat (append envdat (list varval)))
			    (safe-setenv (car varval)(cadr varval)))
			  (configf:get-section runconfig section)))
	      (list "default" target))
    (vector target runname testpatt keys keyvals envdat mconfig runconfig (common:get-remote remote run-id) transport db toppath run-id)))
;;;;;; ;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
;;;;;; ;;
;;;;;; (define (runs:create-run-record area-dat) ;; #!key (remote #f))
;;;;;;   (let* ((remote       (megatest:area-remote area-dat))
;;;;;; 	 (mconfig      (if *configdat*
;;;;;; 		           *configdat*
;;;;;; 		           (if (launch:setup-for-run)
;;;;;; 		               *configdat*
;;;;;; 		               (begin
;;;;;; 		                 (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
;;;;;; 		                 (exit 1)))))
;;;;;; 	  (runrec      (runs:runrec-make-record))
;;;;;; 	  (target      (common:args-get-target))
;;;;;; 	  (runname     (or (args:get-arg "-runname")
;;;;;; 		           (args:get-arg ":runname")))
;;;;;; 	  (testpatt    (or (args:get-arg "-testpatt")
;;;;;; 		           (args:get-arg "-runtests")))
;;;;;; 	  (keys        (keys:config-get-fields mconfig))
;;;;;; 	  (keyvals     (keys:target->keyval keys target))
;;;;;; 	  (toppath     *toppath*)
;;;;;; 	  (envdat      keyvals) ;; initial values start with keyvals
;;;;;; 	  (runconfig   #f)
;;;;;; 	  (transport   (or (args:get-arg "-transport") 'http))
;;;;;; 	  (run-id      #f))
;;;;;;     ;; Set all the environment vars we know so far, start with keys
;;;;;;     (for-each (lambda (keyval)
;;;;;; 		(setenv (car keyval)(cadr keyval)))
;;;;;; 	      keyvals)
;;;;;;     ;; Set up various and sundry known vars here
;;;;;;     (setenv "MT_RUN_AREA_HOME" toppath)
;;;;;;     (setenv "MT_RUNNAME" runname)
;;;;;;     (setenv "MT_TARGET"  target)
;;;;;;     (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))
;;;;;;     (set! envdat (append 
;;;;;; 		  envdat
;;;;;; 		  (list (list "MT_RUN_AREA_HOME" toppath)
;;;;;; 			(list "MT_RUNNAME"       runname)
;;;;;; 			(list "MT_TARGET"        target))))
;;;;;;     ;; Now can read the runconfigs file
;;;;;;     ;; 
;;;;;;     (set! runconfig (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))
;;;;;;     (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f))
;;;;;; 	(begin
;;;;;; 	  (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
;;;;;; 	  (if db (sqlite3:finalize! db))
;;;;;; 	  (exit 1)))
;;;;;;     ;; Now have runconfigs data loaded, set environment vars
;;;;;;     (for-each (lambda (section)
;;;;;; 		(for-each (lambda (varval)
;;;;;; 			    (set! envdat (append envdat (list varval)))
;;;;;; 			    (safe-setenv (car varval)(cadr varval)))
;;;;;; 			  (configf:get-section runconfig section)))
;;;;;; 	      (list "default" target))
;;;;;;     (vector target runname testpatt keys keyvals envdat mconfig runconfig (common:get-remote remote run-id) transport db toppath run-id)))

(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
  (let* ((target    (or (common:args-get-target)
(define (runs:set-megatest-env-vars run-id area-dat #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
  (let* ((configdat (megatest:area-configdat area-dat))
	 (target    (or (common:args-get-target)
			(get-environment-variable "MT_TARGET")))
	 (keys    (if inkeys    inkeys    (rmt:get-keys)))
	 (keyvals   (if inkeyvals inkeyvals (keys:target->keyval keys target)))
	 (vals      (hash-table-ref/default *env-vars-by-run-id* run-id #f))
	 (link-tree (configf:lookup *configdat* "setup" "linktree")))
	 (link-tree (configf:lookup configdat "setup" "linktree")))
    ;; get the info from the db and put it in the cache
    (if link-tree
	(setenv "MT_LINKTREE" link-tree)
	(debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section."))
    (if (not vals)
	(let ((ht (make-hash-table)))
	  (hash-table-set! *env-vars-by-run-id* run-id ht)
	  (set! vals ht)
	  (for-each
	   (lambda (key)
	     (hash-table-set! vals (car key) (cadr key)))
	   keyvals)))
    ;; from the cached data set the vars
    (hash-table-for-each
     vals
     (lambda (key val)
       (debug:print 2 "setenv " key " " val)
       (safe-setenv key val)))
    (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
    (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
    (alist->env-vars (hash-table-ref/default configdat "env-override" '()))
    ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
    (let ((runname  (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
      (if runname
	  (setenv "MT_RUNNAME" runname)
	  (debug:print 0 "ERROR: no value for runname for id " run-id)))
    (setenv "MT_RUN_AREA_HOME" *toppath*)))

	(currtime (current-seconds)))
    (if (> (- currtime lasttime) waitval)
	(begin
	  (hash-table-set! *runs:denoise* key currtime)
	  #t)
	#f)))

(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)
(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs area-dat)
  (thread-sleep! (cond
        	  ((> *runs:can-run-more-tests-count* 20)
		   (if (runs:lownoise "waiting on tasks" 60)
		       (debug:print-info 2 "waiting for tasks to complete, sleeping briefly ..."))
		   2);; obviously haven't had any work to do for a while
        	  (else 0)))
  (let* ((configdat               (megatest:area-configdat area-dat))
  (let* ((num-running             (rmt:get-count-tests-running run-id))
	 (num-running             (rmt:get-count-tests-running run-id))
	 (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
	 (job-group-limit         (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
	 (job-group-limit         (let ((jobg-count (config-lookup configdat "jobgroups" jobgroup)))
				    (if (string? jobg-count)
					(string->number jobg-count)
					jobg-count))))
    (if (> (+ num-running num-running-in-jobgroup) 0)
	(set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
    (if (not (eq? *last-num-running-tests* num-running))
	(begin

	  (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))


;;  test-names: Comma separated patterns same as test-patts but used in selection 
;;              of tests to run. The item portions are not respected.
;;              FIXME: error out if /patt specified
;;            
(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
(define (runs:run-tests target runname test-patts user flags area-dat #!key (run-count 3)) ;; test-names
  (let* ((configdat          (megatest:area-configdat area-dat))
	 (toppath            (megatest:area-path      area-dat))
	 (keys               (keys:config-get-fields configdat))
	 (keyvals            (keys:target->keyval keys target))
	 (run-id             (rmt:register-run keyvals runname "new" "n/a" user))  ;;  test-name)))
	 (run-id             (rmt:register-run keyvals runname "new" "n/a" user area-dat))  ;;  test-name)))
	 (deferred          '()) ;; delay running these since they have a waiton clause
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
	 (runconfigf         (conc  toppath "/runconfigs.config"))
	 (test-records       (make-hash-table))
	 ;; need to process runconfigs before generating these lists
	 (all-tests-registry #f)  ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     #f)  ;; (hash-table-keys all-tests-registry))
	 (test-names         #f)  ;; (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)  ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work
	 (task-key           (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))

    (set! test-names         (tests:filter-test-names all-test-names test-patts))
    (set! required-tests     (lset-intersection equal? (string-split test-patts ",") test-names))
    
    ;; look up all tests matching the comma separated list of globs in
    ;; test-patts (using % as wildcard)

    ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts)))
    (debug:print-info 0 "tests search path: " (tests:get-tests-search-path *configdat*))
    (debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat))
    (debug:print-info 0 "all tests:  " (string-intersperse (sort all-test-names string<) " "))
    (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " "))

    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
	(begin

	  ;;
	  ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED")
	  
	  ;; Now convert FAIL and anything in allow-auto-rerun to NOT_STARTED
	  ;;
	  (for-each (lambda (state)
		      (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state))
		    (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") "")))))
		    (string-split (or (configf:lookup configdat "setup" "allow-auto-rerun") "")))))

    ;; Ensure all tests are registered in the test_meta table
    (runs:update-all-test_meta #f)

    ;; now add non-directly referenced dependencies (i.e. waiton)
    ;;======================================================================
    ;; refactoring this block into tests:get-full-data

	      (if (not (null? remtests))
		  (loop (car remtests)(cdr remtests)))))))

    (if (not (null? required-tests))
	(debug:print-info 1 "Adding " required-tests " to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 "test-records=" (hash-table->alist test-records))
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
    (let ((reglen (configf:lookup configdat "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)
		 (run-queue-retries 5)
		 (th1        (make-thread (lambda ()
					    (handle-exceptions
					     exn
					     (begin
					       (print-call-chain (current-error-port))
					       (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn))
					       (if (> run-queue-retries 0)
						   (begin
						     (set! run-queue-retries (- run-queue-retries 1))
						     (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))))
					     (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))
						     (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry area-dat))))
					     (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry area-dat)))
					  "runs:run-tests-queue"))
		 (th2        (make-thread (lambda ()				    
					    ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
					    (let ((run-ids (rmt:get-all-run-ids)))
					      (for-each (lambda (run-id)
							  (if keep-going
							      (handle-exceptions

	    ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD
	    (if (> run-count 0)
		(begin
		  (if (not (hash-table-ref/default flags "-preclean" #f))
		      (hash-table-set! flags "-preclean" #t))
		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
		  (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
		  (runs:run-tests target runname test-patts user flags area-dat run-count: (- run-count 1)))))
	  (debug:print-info 0 "No tests to run")))
    (debug:print-info 4 "All done by here")
    (rmt:tasks-set-state-given-param-key task-key "done")
    ;; (sqlite3:finalize! tasks-db)
    ))

		 (conc test-name (if (equal? item-path "") "" "/") item-path ":" test-state "/" test-status)))
	      ((string? t)
	       t)
	      (else 
	       (conc t))))
	   inlst)))

(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap)
  (let* ((run-limits-info         (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap area-dat)
  (let* ((configdat               (megatest:area-configdat area-dat))
	 (toppath                 (megatest:area-path      area-dat))
	 (run-limits-info         (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 (have-resources          (car run-limits-info))
	 (num-running             (list-ref run-limits-info 1))
	 (num-running-in-jobgroup (list-ref run-limits-info 2)) 
	 (max-concurrent-jobs     (list-ref run-limits-info 3))
	 (job-group-limit         (list-ref run-limits-info 4))
	 (prereqs-not-met         (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap))
	 ;; (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails                   (runs:calc-fails prereqs-not-met))
	 (non-completed           (runs:calc-not-completed prereqs-not-met))
	 (loop-list               (list hed tal reg reruns))
	 ;; configure the load runner
	 (numcpus                 (common:get-num-cpus))
	 (maxload                 (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3")))
	 (waitdelay               (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))
	 (maxload                 (string->number (or (configf:lookup configdat "jobtools" "maxload") "3")))
	 (waitdelay               (string->number (or (configf:lookup configdat "jobtools" "waitdelay") "60"))))
    (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" 
		      (string-intersperse 
		       (map (lambda (t)
			      (if (vector? t)
				  (conc (db:test-get-state t) "/" (db:test-get-status t))
				  (conc " WARNING: t is not a vector=" t )))
			    prereqs-not-met) ", ") ") fails: " fails)

		    (null? non-completed))))
      ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path))
      ;; we are going to reset all the counters for test retries by setting a new hash table
      ;; this means they will increment only when nothing can be run
      (set! *max-tries-hash* (make-hash-table))
      ;; well, first lets see if cpu load throttling is enabled. If so wait around until the
      ;; average cpu load is under the threshold before continuing
      (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified
      (if (configf:lookup configdat "jobtools" "maxload") ;; only gate if maxload is specified
	  (common:wait-for-cpuload maxload numcpus waitdelay))
      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
      (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
      (runs:shrink-can-run-more-tests-count)  ;; DELAY TWEAKER (still needed?)
      ;; (thread-sleep! *global-delta*)
      (if (or (not (null? tal))(not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)

;; every time though the loop increment the test/itempatt val.
;; when the min is > max-allowed and none running then force exit
;;
(define *max-tries-hash* (make-hash-table))

;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry)
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry area-dat)
  ;; At this point the list of parent tests is expanded 
  ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags))

  ;; Do mark-and-find clean up of db before starting runing of quue
  ;;
  ;; (cdb:remote-run db:find-and-mark-incomplete #f)

  (let ((configdat             (megatest:area-configdat area-dat))
	(toppath               (megatest:area-path      area-dat))
  (let ((run-info              (rmt:get-run-info run-id))
	(run-info              (rmt:get-run-info run-id area-dat))
	(tests-info            (mt:get-tests-for-run run-id #f '() '())) ;;  qryvals: "id,testname,item_path"))
	(sorted-test-names     (tests:sort-by-priority-and-waiton test-records))
	(test-registry         (make-hash-table))
	(registry-mutex        (make-mutex))
	(num-retries           0)
	(max-retries           (config-lookup *configdat* "setup" "maxretries"))
	(max-concurrent-jobs   (let ((mcj (config-lookup *configdat* "setup"     "max_concurrent_jobs")))
	(max-retries           (config-lookup configdat "setup" "maxretries"))
	(max-concurrent-jobs   (let ((mcj (config-lookup configdat "setup"     "max_concurrent_jobs")))
				 (if (and mcj (string->number mcj))
				     (string->number mcj)
				     1))) ;; length of the register queue ahead
	(reglen                (if (number? reglen-in) reglen-in 1))
	(last-time-incomplete  (- (current-seconds) 900)) ;; force at least one clean up cycle
	(last-time-some-running (current-seconds))
	(tdbdat                (tasks:open-db)))

	     (priority    (tests:testqueue-get-priority   test-record))
	     (itemdat     (tests:testqueue-get-itemdat    test-record)) ;; itemdat can be a string, list or #f
	     (items       (tests:testqueue-get-items      test-record))
	     (item-path   (item-list->path itemdat))
	     (tfullname   (db:test-make-full-name test-name item-path))
	     (newtal      (append tal (list hed)))
	     (regfull     (>= (length reg) reglen))
	     (num-running (rmt:get-count-tests-running-for-run-id run-id)))
	     (num-running (rmt:get-count-tests-running-for-run-id run-id area-dat)))

	;; every couple minutes verify the server is there for this run
	(if (and (common:low-noise-print 60 "try start server"  run-id)
		 (tasks:need-server run-id))
	    (tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood
	
	(if (> num-running 0)
	  (set! last-time-some-running (current-seconds)))

      (if (> (current-seconds)(+ last-time-some-running 240))
	  (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
	;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*))

	;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
	;; and it is clear they *should* have run but did not.
	(if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f))
	    (begin
	      (rmt:general-call 'register-test run-id run-id test-name "")
	      (rmt:general-call 'register-test run-id run-id test-name "" area-dat)
	      (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))
	
	;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :(
	;;
	(if (member (hash-table-ref/default test-registry tfullname #f) 
		    '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))
	    (begin

	  (debug:print-info 0 "Have leftovers!")
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
	  (debug:print-info 4 "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 )))
    ;; now *if* -run-wait we wait for all tests to be done
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id area-dat))
		    (prev-num-running 0))
      ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")
		   (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
		   (equal? (configf:lookup configdat "setup" "run-wait") "yes"))
	       (> num-running 0))
	  (begin
	    ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
	    ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
	    (if (> (current-seconds)(+ last-time-incomplete 900))
		(begin
		  (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name))
		  (set! last-time-incomplete (current-seconds))
		  (rmt:find-and-mark-incomplete run-id #f)))
		  (rmt:find-and-mark-incomplete run-id #f area-dat)))
	    (if (not (eq? num-running prev-num-running))
		(debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))
	    (thread-sleep! 5)
	    ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
	    (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
	    (wait-loop (rmt:get-count-tests-running-for-run-id run-id area-dat) num-running))))
    ;; LET* ((test-record
    ;; we get here on "drop through". All done!
    (debug:print-info 1 "All tests launched")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))

	 (test-waitons (tests:testqueue-get-waitons    test-record))
	 (test-conf    (tests:testqueue-get-testconfig test-record))
	 (itemdat      (tests:testqueue-get-itemdat    test-record))
	 (test-path    (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
	 (force        (hash-table-ref/default flags "-force" #f))
	 (rerun        (hash-table-ref/default flags "-rerun" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	 (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x")))
	 (incomplete-timeout (string->number (or (configf:lookup configdat "setup" "incomplete-timeout") "x")))
	 (item-path     "")
	 (db           #f)
	 (full-test-name #f))

    ;; setting itemdat to a list if it is #f
    (if (not itemdat)(set! itemdat '()))
    (set! item-path (item-list->path itemdat))

    (if (not (hash-table-ref/default *test-meta-updated* test-name #f))
        (begin
	   (hash-table-set! *test-meta-updated* test-name #t)
           (runs:update-test_meta test-name test-conf)))
    
    ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
    (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
	   (test-id       (rmt:get-test-id run-id test-name item-path))
	   (testdat       (if test-id (rmt:get-test-info-by-id run-id test-id) #f)))
	   (test-id       (rmt:get-test-id run-id test-name item-path area-dat))
	   (testdat       (if test-id (rmt:get-test-info-by-id run-id test-id area-dat) #f)))
      (if (not testdat)
	  (let loop ()
	    ;; ensure that the path exists before registering the test
	    ;; NOPE: Cannot! Don't know yet which disk area will be assigned....
	    ;; (system (conc "mkdir -p " new-test-path))
	    ;;
	    ;; (open-run-close tests:register-test db run-id test-name item-path)
	    ;;
	    ;; NB// for the above line. I want the test to be registered long before this routine gets called!
	    ;;
	    (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path)))
	    (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path area-dat)))
	    (if (not test-id)
		(begin
		  (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
		  (rmt:general-call 'register-test run-id run-id test-name item-path)
		  (set! test-id (rmt:get-test-id run-id test-name item-path))))
		  (rmt:general-call 'register-test run-id run-id test-name item-path area-dat)
		  (set! test-id (rmt:get-test-id run-id test-name item-path area-dat))))
	    (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
	    (set! testdat (rmt:get-test-info-by-id run-id test-id))
	    (set! testdat (rmt:get-test-info-by-id run-id test-id area-dat))
	    (if (not testdat)
		(begin
		  (debug:print-info 0 "WARNING: server is overloaded, trying again in one second")
		  (thread-sleep! 1)
		  (loop)))))
      (if (not testdat) ;; should NOT happen
	  (debug:print 0 "ERROR: failed to get test record for test-id " test-id))

		     (skip-check  (configf:get-section test-conf "skip")))
		 (cond 
		  ;; Have to check for skip conditions. This one skips if there are same-named tests
		  ;; currently running
		  ((and skip-check
			(configf:lookup test-conf "skip" "prevrunning"))
		   ;; run-ids = #f means *all* runs
		   (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)))
		   (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f area-dat)))
		     (if (not (null? running-tests)) ;; have to skip 
			 (set! skip-test "Skipping due to previous tests running"))))
		  ((and skip-check
			(configf:lookup test-conf "skip" "fileexists"))
		   (if (file-exists? (configf:lookup test-conf "skip" "fileexists"))
		       (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists"))))))
		 (if skip-test

;; fields are passing in through 
;; action:
;;    'remove-runs
;;    'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '()))
(define (runs:operate-on action target runnamepatt testpatt area-dat #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '()))
  (common:clear-caches) ;; clear all caches
  (let* ((db           #f)
	 (tdbdat       (tasks:open-db))
	 (keys         (rmt:get-keys))
	 (keys         (rmt:get-keys area-dat))
	 (rundat       (mt:get-runs-by-patt keys runnamepatt target))
	 (header       (vector-ref rundat 0))
	 (runs         (vector-ref rundat 1))
	 (states       (if state  (string-split state  ",") '()))
	 (statuses     (if status (string-split status ",") '()))
	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))))
    (debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)

									 #f))))))
		       (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests
		       (test-retry-time  (make-hash-table))
		       (allow-run-time   10)) ;; seconds to allow for killing tests before just brutally killing 'em
		   (let loop ((test (car sorted-tests))
			      (tal  (cdr sorted-tests)))
		     (let* ((test-id       (db:test-get-id test))
			    (new-test-dat  (rmt:get-test-info-by-id run-id test-id)))
			    (new-test-dat  (rmt:get-test-info-by-id run-id test-id area-dat)))
		       (if (not new-test-dat)
			   (begin
			     (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
			     (if (not (null? tal))
				 (loop (car tal)(cdr tal))))
			   (let* ((item-path     (db:test-get-item-path new-test-dat))
				  (test-name     (db:test-get-testname new-test-dat))
				  (run-dir       ;;(filedb:get-path *fdb*
				   ;; (rmt:sdb-qry 'getid 
				   (db:test-get-rundir new-test-dat)) ;; )    ;; run dir is from the link tree
				  (test-state    (db:test-get-state new-test-dat))
				  (test-fulln    (db:test-get-fullname new-test-dat))
				  (uname         (db:test-get-uname    new-test-dat))
				  (toplevel-with-children (and (db:test-get-is-toplevel test)
							       (> (rmt:test-toplevel-num-items run-id test-name) 0))))
							       (> (rmt:test-toplevel-num-items run-id test-name area-dat) 0))))
			     (case action
			       ((remove-runs)
				;; if the test is a toplevel-with-children issue an error and do not remove
				(if toplevel-with-children
				    (begin
				      (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
				      (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))

	       (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t)))
		 (if (null? remtests) ;; no more tests remaining
		     (let* ((dparts  (string-split lasttpath "/"))
			    (runpath (conc "/" (string-intersperse 
						(take dparts (- (length dparts) 1))
						"/"))))
		       (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
		       (rmt:delete-run run-id)
		       (rmt:delete-old-deleted-test-records)
		       (rmt:delete-run run-id area-dat)
		       (rmt:delete-old-deleted-test-records area-dat)
		       ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds))
		       ;; need to figure out the path to the run dir and remove it if empty
		       ;;    (if (null? (glob (conc runpath "/*")))
		       ;;        (begin
		       ;; 	 (debug:print 1 "Removing run dir " runpath)
		       ;; 	 (system (conc "rmdir -p " runpath))))
		       )))))

		(debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
		(debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
	    ))
    ;; Only delete the records *after* removing the directory. If things fail we have a record 
    (case mode
      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f))
      ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f))
      (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))))
      (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test) area-dat)))))

;;======================================================================
;; Routines for manipulating runs
;;======================================================================

;; Since many calls to a run require pretty much the same setup 
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
  (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname")))
	(target  (common:args-get-target)))
(define (general-run-call switchname action-desc proc area-dat)
  (let ((runname   (or (args:get-arg "-runname")(args:get-arg ":runname")))
	(target    (common:args-get-target))
	(toppath   (megatest:area-path area-dat))
	(configdat (megatest:area-configdat area-dat))
	(configinfo (megatest:area-configinfo area-dat)))
    (cond
     ((not target)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
      (exit 3))
     ((not runname)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
      (exit 3))
     (else
      (let (;; (db   #f)
	    (keys #f))
	(if (launch:setup-for-run)
	    (launch:cache-config)
	(if (launch:setup-for-run area-dat)
	    (launch:cache-config area-dat)
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	;; (if (args:get-arg "-server")
	;;     (cdb:remote-run server:start db (args:get-arg "-server")))
	(set! keys (keys:config-get-fields *configdat*))
	(set! keys (keys:config-get-fields configdat))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 
	    (let* ((runconfigf (conc  toppath "/runconfigs.config")) ;; DO NOT EVALUATE ALL 
		   (runconfig  (read-config runconfigf #f #t environ-patt: #f)))
	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
		    
		  (begin
		    (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    ;; (if db (sqlite3:finalize! db))
		    (exit 1)
		    )))
	    (if (args:get-arg "-target")
		(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
	(if (not (car *configinfo*))
	(if (not (car configinfo))
	    (begin
	      (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
	      (exit 1))
	    ;; Extract out stuff needed in most or many calls
	    ;; here then call proc
	    (let* ((keyvals    (keys:target->keyval keys target)))
	      (proc target runname keys keyvals)))

    (for-each (lambda (run)
		(let ((run-id (db:get-value-by-header run header "id")))
		  (if (or lock
			  (and unlock
			       (begin
				 (print "Do you really wish to unlock run " run-id "?\n   y/n: ")
				 (equal? "y" (read-line)))))
		      (rmt:lock/unlock-run run-id lock unlock user)
		      (rmt:lock/unlock-run run-id lock unlock user area-dat)
		      (debug:print-info 0 "Skipping lock/unlock on " run-id))))
	      runs)))
;;======================================================================
;; Rollup runs
;;======================================================================

;; Update the test_meta table for this test
(define (runs:update-test_meta test-name test-conf)
  (let ((currrecord (rmt:testmeta-get-record test-name)))
(define (runs:update-test_meta test-name test-conf area-dat)
  (let ((currrecord (rmt:testmeta-get-record test-name area-dat)))
    (if (not currrecord)
	(begin
	  (set! currrecord (make-vector 11 #f))
	  (rmt:testmeta-add-record test-name)))
	  (rmt:testmeta-add-record test-name area-dat)))
    (for-each 
     (lambda (key)
       (let* ((idx (cadr key))
	      (fld (car  key))
	      (val (config-lookup test-conf "test_meta" fld)))
	 ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
	 (if (and val (not (equal? (vector-ref currrecord idx) val)))
	     (begin
	       (print "Updating " test-name " " fld " to " val)
	       (rmt:testmeta-update-field test-name fld val)))))
	       (rmt:testmeta-update-field test-name fld val area-dat)))))
     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))

;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
  (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests)))
    (for-each 
     (lambda (test-name)
       (let* ((test-conf    (mt:lazy-read-test-config test-name)))
	 (if test-conf (runs:update-test_meta test-name test-conf))))
     (hash-table-keys test-names))))

;; This could probably be refactored into one complex query ...
;; NOT PORTED - DO NOT USE YET
;;
(define (runs:rollup-run keys runname user keyvals)
(define (runs:rollup-run keys runname user keyvals area-dat)
  (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user)
  (let* ((db              #f)
	 ;; register run operates on the main db
	 (new-run-id      (rmt:register-run keyvals runname "new" "n/a" user))
	 (prev-tests      (rmt:get-matching-previous-test-run-records new-run-id "%" "%"))
	 (curr-tests      (mt:get-tests-for-run new-run-id "%/%" '() '()))
	 (new-run-id      (rmt:register-run keyvals runname "new" "n/a" user area-dat))
	 (prev-tests      (rmt:get-matching-previous-test-run-records new-run-id "%" "%" area-dat))
	 (curr-tests      (mt:get-tests-for-run new-run-id "%/%" '() '() area-dat))
	 (curr-tests-hash (make-hash-table)))
    (rmt:update-run-event_time new-run-id)
    (rmt:update-run-event_time new-run-id area-dat)
    ;; index the already saved tests by testname and itemdat in curr-tests-hash
    (for-each
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path)))
	 (hash-table-set! curr-tests-hash full-name testdat)))
     curr-tests)
    ;; NOPE: Non-optimal approach. Try this instead.
    ;;   1. tests are received in a list, most recent first
    ;;   2. replace the rollup test with the new *always*
    (for-each 
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path))
	      (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f))
	      (test-steps    (rmt:get-steps-for-test (db:test-get-id testdat)))
	      (test-steps    (rmt:get-steps-for-test (db:test-get-id testdat) area-dat))
	      (new-test-record #f))
	 ;; replace these with insert ... select
	 (apply sqlite3:execute 
		db 
		(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "
		      "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
		new-run-id (cddr (vector->list testdat)))

;; 	      (rpc-transport:launch run-id)))))

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

;; Get the transport
(define (server:get-transport)
  (if *transport-type*
      *transport-type*
(define (server:get-transport area-dat)
  (if (megatest:area-transport area-dat)
      (megatest-area-transport area-dat)
      (let ((ttype (string->symbol
		    (or (args:get-arg "-transport")
			(configf:lookup *configdat* "server" "transport")
			(configf:lookup (megatest:area-configdat area-dat) "server" "transport")
			"rpc"))))
	(set! *transport-type* ttype)
	(megatest:area-transport-set! area-dat ttype)
	ttype)))
	    
;; Generate a unique signature for this server
(define (server:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()

     (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*)
     result)))

;; Given a run id start a server process    ### NOTE ### > file 2>&1 
;; if the run-id is zero and the target-host is set 
;; try running on that host
;;
(define  (server:run run-id)
  (let* ((curr-host   (get-host-name))
(define  (server:run run-id area-dat)
  (let* ((configdat   (megatest:area-configdat area-dat))
	 (toppath     (megatest:area-path      area-dat))
	 (curr-host   (get-host-name))
	 (curr-ip     (server:get-best-guess-address curr-host))
	 (target-host (configf:lookup *configdat* "server" "homehost" ))
	 (target-host (configf:lookup configdat "server" "homehost" ))
	 (testsuite   (common:get-testsuite-name))
	 (logfile     (conc *toppath* "/logs/" run-id ".log"))
	 (logfile     (conc toppath "/logs/" run-id ".log"))
	 (cmdln (conc (common:get-megatest-exe)
		      " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
		      " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup configdat "server" "daemonize") "yes")
									      (conc " -daemonize -log " logfile)
									      "")
		      " -debug 4 testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &")))))
    (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
    (push-directory *toppath*)
    (push-directory toppath)
    (if (not (directory-exists? "logs"))(create-directory "logs"))
    ;; host.domain.tld match host?
    (if (and target-host 
	     ;; look at target host, is it host.domain.tld or ip address and does it 
	     ;; match current ip or hostname
	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
	     (not (equal? curr-ip target-host)))

	(begin
	  ;; (debug:print-info 2 "login successful")
	  #t)
	(begin
	  ;; (debug:print-info 2 "login failed")
	  #f))))

(define (server:get-timeout)
  (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
(define (server:get-timeout area-dat)
  (let ((tmo (configf:lookup  (megatest:area-configdat area-dat) "server" "timeout")))
    (if (and (string? tmo)
	     (string->number tmo))
	(* 60 60 (string->number tmo))
	;; (* 3 24 60 60) ;; default to three days
	(* 60 1)         ;; default to one minute
	;; (* 60 60 25)      ;; default to 25 hours
	)))

		       (loop (file-exists? fullpath)
			     (- count 1)))
		     (begin
		       (if remove (system (conc "rm -rf " fullpath)))
		       #f)))
	       #t))))))

(define (tasks:get-task-db-path)
  (let* ((linktree     (configf:lookup *configdat* "setup" "linktree"))
(define (tasks:get-task-db-path area-dat)
  (let* ((linktree     (configf:lookup (megatest:area-configdat area-dat) "setup" "linktree"))
	 (dbpath       (conc linktree "/.db")))
    dbpath))



;; If file exists AND
;;    file readable
;;         ==> open it
;; If file exists AND
;;    file NOT readable
;;         ==> open in-mem version
;; If file NOT exists
;;    ==> open in-mem version
;;
(define (tasks:open-db #!key (numretries 4))
(define (tasks:open-db area-dat #!key (numretries 4))
  (if *task-db*
      *task-db*
      (handle-exceptions
       exn
       (if (> numretries 0)
	   (begin
	     (print-call-chain (current-error-port))
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 0 " exn=" (condition->list exn))
	     (thread-sleep! 1)
	     (tasks:open-db numretries (- numretries 1)))
	     (tasks:open-db area-dat numretries: (- numretries 1)))
	   (begin
	     (print-call-chain (current-error-port))
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 0 " exn=" (condition->list exn))))
       (let* ((toppath      (megatest:area-path area-dat))
       (let* ((dbpath       (tasks:get-task-db-path))
	      (dbpath       (tasks:get-task-db-path area-dat))
	      (dbfile       (conc dbpath "/monitor.db"))
	      (avail        (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
	      (exists       (file-exists? dbpath))
	      (write-access (file-write-access? dbpath))
	      (mdb          (cond ;; what the hek is *toppath* doing here?
			     ((and (string? *toppath*)(file-write-access? *toppath*))
			     ((and (string? toppath)(file-write-access? toppath))
			      (sqlite3:open-database dbfile))
			     ((file-read-access? dbpath)    (sqlite3:open-database dbfile))
			     (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
	      (handler      (make-busy-timeout 36000)))
	 (if (and exists
		  (not write-access))
	     (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control

                                  hostname TEXT,
                                  cmdline TEXT,
                                  login_time TIMESTAMP,
                                  logout_time TIMESTAMP DEFAULT -1,
                                CONSTRAINT clients_constraint UNIQUE (pid,hostname));")
	       
	       ;))
	 (set! *task-db* (cons mdb dbpath))
	 (set! *task-db* (cons mdb dbpath)) ;; Move into area-dat !!!!
	 *task-db*))))

;;======================================================================
;; Server and client management
;;======================================================================

;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname

  (setenv "TARGETHOST_LOGF" "server-kills.log")
  (system (conc "nbfake kill " pid))
  (unsetenv "TARGETHOST_LOGF")
  (unsetenv "TARGETHOST"))
 
;; look up a server by run-id and send it a kill, also delete the record for that server
;;
(define (tasks:kill-server-run-id run-id #!key (tag "default"))
  (let* ((tdbdat  (tasks:open-db))
(define (tasks:kill-server-run-id run-id area-dat #!key (tag "default"))
  (let* ((tdbdat  (tasks:open-db area-dat))
	 (sdat    (tasks:get-server (db:delay-if-busy tdbdat) run-id)))
    (if sdat
	(let ((hostname (vector-ref sdat 6))
	      (pid      (vector-ref sdat 5))
	      (server-id (vector-ref sdat 0)))
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed")
	  (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid)

     target run-name state-patt action-patt test-patt)
    res)) ;; )

;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
;; 
;; do a remote call to get the task queue info but do the killing as self here.
;;
(define (tasks:kill-runner target run-name)
  (let ((records    (rmt:tasks-find-task-queue-records target run-name "%" "running" "run-tests"))
(define (tasks:kill-runner target run-name area-dat)
  (let ((records    (rmt:tasks-find-task-queue-records target run-name "%" "running" "run-tests" area-dat))
	(hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string
    (if (null? records)
	(debug:print 0 "No run launching processes found for " target " / " run-name)
	(debug:print 0 "Found " (length records) " run(s) to kill."))
    (for-each 
     (lambda (record)
       (let* ((param-key (list-ref record 8))

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dashboard -rows 15 &

dashboard : cleanprep
	cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) &

newdashboard : cleanprep
	cd fullrun && $(BINPATH)/newdashboard &
olddashboard : cleanprep
	cd fullrun && $(BINPATH)/olddashboard &

remove :
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN)  -testpatt % -itempatt % :sysname % :fsname % :datapath %

clean  : 
	rm cleanprep