Megatest

    (if (not dbexists)
	(db:initialize db))
    (db:set-sync db)
    db))

;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling  proc idb . params)
  (let* ((db   (if idb idb (open-db)))
	 (res #f))
    (set! res (apply proc db params))
    (if (not idb)(sqlite3:finalize! db))
    res))

(define (open-run-close-exception-handling proc idb . params)
  (let ((runner (lambda ()
		  (let* ((db   (if idb idb (open-db)))
			 (res #f))
		    (set! res (apply proc db params))
		    (if (not idb)(sqlite3:finalize! db))
		    res))))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "EXCEPTION: database probably overloaded?")
       (debug:print 0 "  " ((condition-property-accessor 'exn 'message) exn))
       (print-call-chain)
       (thread-sleep! (random 120))
       (debug:print 0 "trying db call one more time....")
       (runner))
     (runner))))

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

(define *global-delta* 0)
(define *last-global-delta-printed* 0)

(define (open-run-close-measure  proc idb . params)

	      expected REAL,
	      tol REAL,
              units TEXT,
              comment TEXT DEFAULT '',
              status TEXT DEFAULT 'n/a',
              type TEXT DEFAULT '',
              CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"
	 "CREATE TABLE IF NOT EXISTS test_steps (
              id INTEGER PRIMARY KEY,
              test_id INTEGER, 
              stepname TEXT, 
              state TEXT DEFAULT 'NOT_STARTED', 
              status TEXT DEFAULT 'n/a',
              event_time TIMESTAMP,
              comment TEXT DEFAULT '',
              logfile TEXT DEFAULT '',
              CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"
	 ;; test_meta can be used for handing commands to the test
	 ;; e.g. KILLREQ
	 ;;      the ackstate is set to 1 once the command has been completed
	 "CREATE TABLE IF NOT EXISTS test_meta (
              id INTEGER PRIMARY KEY,
              var TEXT,
              val TEXT,
              ackstate INTEGER DEFAULT 0,
              CONSTRAINT metadat_constraint UNIQUE (var));")))

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

		             remfields))
	 (keystr     (conc (keys->keystr keys) ","
		           (string-intersperse remfields ",")))
	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
		           ;; Generate: " AND x LIKE 'keypatt' ..."
		           (if (null? keypatts) ""
		               (conc " AND "
				     (string-join 
				      (map (lambda (keypatt)
					     (let ((key  (car keypatt))
						   (patt (cadr keypatt)))
					       (db:patt->like key patt)))
					   keypatts)
				      " AND ")))
		           " ORDER BY event_time DESC "
		           (if (number? count)
		               (conc " LIMIT " count)
		               "")
		           (if (number? offset)
		               (conc " OFFSET " offset)
		               ""))))

	   (set! res (apply vector a x)))
	 db
	 (conc "SELECT " keystr " FROM runs WHERE id=?;")
	 run-id)
	(let ((finalres (vector header res)))
	  (hash-table-set! *run-info-cache* run-id finalres)
	  finalres))))

(define (db:set-comment-for-run db run-id comment)
  (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id))

;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run db run-id)
  (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id))

	   test-id)
	  (hash-table-set! *test-paths* test-id res)
	  res))))

(define (db:test-set-log! db test-id logf)
  (if (string? logf)
      (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE id=?;"
		       logf test-id)
      (debug:print 0 "ERROR: db:test-set-log! called with non-string log file name " logf)))

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

(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '()))

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

(define (db:updater)
  (let loop ((start-time (current-time)))
    (thread-sleep! 15) ;; move save time around to minimize regular collisions?
    (db:write-cached-data)
    (loop start-time)))

(define (cdb:test-set-status-state test-id status state msg)
  (debug:print 4 "INFO: cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg)
  (mutex-lock! *incoming-mutex*)
  (if msg
      (set! *incoming-data* (cons (vector 'state-status-msg
					  (current-seconds)
					  (list state status msg test-id))
				  *incoming-data*))
      (set! *incoming-data* (cons (vector 'state-status
					  (current-seconds)
					  (list state status test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) 
				  *incoming-data*)))
  (mutex-unlock! *incoming-mutex*)
  (if *cache-on*
      (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write")
      (db:write-cached-data)))
  
(define (cdb:test-rollup-iterated-pass-fail test-id)
  (debug:print 4 "INFO: Adding " test-id " for iterated rollup to the queue")
  (mutex-lock! *incoming-mutex*)
  (set! *incoming-data* (cons (vector 'iterated-p/f-rollup
				      (current-seconds)
				      (list test-id test-id test-id test-id))
			      *incoming-data*))
  (mutex-unlock! *incoming-mutex*)
  (if *cache-on*
      (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write")
      (db:write-cached-data)))

(define (cdb:pass-fail-counts test-id fail-count pass-count)
  (debug:print 4 "INFO: Adding " test-id " for setting pass/fail counts to the queue")
  (mutex-lock! *incoming-mutex*)
  (set! *incoming-data* (cons (vector 'pass-fail-counts
				      (current-seconds)
				      (list fail-count pass-count test-id))
			      *incoming-data*))
  (mutex-unlock! *incoming-mutex*)
  (if *cache-on*
      (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write")
      (db:write-cached-data)))

;; The queue is a list of vectors where the zeroth slot indicates the type of query to
;; apply and the second slot is the time of the query and the third entry is a list of 
;; values to be applied
;;
(define (db:write-cached-data)
  (open-run-close
   (lambda (db . params)
     (let ((state-status-stmt     (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;"))
	   (state-status-msg-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;"))
	   (pass-fail-counts-stmt (sqlite3:prepare db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;"))
	   (iterated-rollup-stmt  (sqlite3:prepare db "UPDATE tests
                                             SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
                                                THEN 'FAIL'
                                             WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
                                                  (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
                                             THEN 'PASS'
                                             ELSE status
                                         END WHERE id=?;"))
	   (data                  #f))
       (mutex-lock! *incoming-mutex*)
       (set! data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))
       (set! *incoming-data* '())
       (mutex-unlock! *incoming-mutex*)
       (if (> (length data) 0)
	   (debug:print 4 "INFO: Writing cached data " data))
       (sqlite3:with-transaction 
	db
	(lambda ()
	  (debug:print 4 "INFO: flushing " data " to db")
	  (for-each (lambda (entry)
		      (let ((params (vector-ref entry 2)))
			(debug:print 4 "INFO: Applying " entry " to params " params)
			(case (vector-ref entry 0)
			  ((state-status)
			   (apply sqlite3:execute state-status-stmt     params))
			  ((state-status-msg)
			   (apply sqlite3:execute state-status-msg-stmt params))
			  ((iterated-p/f-rollup)
			   (apply sqlite3:execute iterated-rollup-stmt  params))
			  ((pass-fail-counts)
			   (apply sqlite3:execute pass-fail-counts-stmt params))
			  (else
			   (debug:print 0 "ERROR: Queued entry not recognised " entry)))))
		    data)))
       (sqlite3:finalize! state-status-stmt)
       (sqlite3:finalize! state-status-msg-stmt)
       (sqlite3:finalize! iterated-rollup-stmt)
       (sqlite3:finalize! pass-fail-counts-stmt)
       (set! *last-db-access* (current-seconds))
       ))
   #f))

(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
  (if (and (not (equal? item-path ""))
	   (or (equal? status "PASS")
	       (equal? status "WARN")

	   tdb 
	   "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
                   (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
	   test-id test-id)
	  (sqlite3:finalize! tdb)

	  ;; Now rollup the counts to the central megatest.db
	  (rdb:pass-fail-counts test-id fail-count pass-count)
	  ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" 
	  ;;                     fail-count pass-count test-id)

	  (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least one second later than the set
	  
	  ;; if the test is not FAIL then set status based on the fail and pass counts.
	  (rdb:test-rollup-iterated-pass-fail test-id)
	  ;; (sqlite3:execute
	  ;;  db   ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME

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

(define (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile)
  (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name)
  (let* ((tdb       (db:open-test-db-by-test-id db test-id))
	 (state     (check-valid-items "state" state-in))
	 (status    (check-valid-items "status" status-in)))
    (if (or (not state)(not status))

;;======================================================================
;; REMOTE DB ACCESS VIA RPC
;;======================================================================

(define (rdb:open-run-close procname . remargs)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	(apply (rpc:procedure 'rdb:open-run-close host port) procname remargs))
      (apply open-run-close (eval procname) remargs)))

(define (rdb:test-set-status-state test-id status state msg)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'cdb:test-set-status-state host port) test-id status state msg))
      (cdb:test-set-status-state test-id status state msg)))

(define (rdb:test-rollup-iterated-pass-fail test-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	(apply (rpc:procedure 'cdb:test-rollup-iterated-pass-fail host port) test-id))
      (cdb:test-rollup-iterated-pass-fail test-id)))

(define (rdb:pass-fail-counts test-id fail-count pass-count)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	(apply (rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count))
      (cdb:pass-fail-counts test-id fail-count pass-count)))