Megatest

(define *incoming-mutex*     (make-mutex))
(define *cache-on* #f)

(define (open-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((dbpath    (conc *toppath* "/megatest.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout 36000)))


    (sqlite3:set-busy-handler! db handler)
    (if (not dbexists)
	(db:initialize db))
    db))

(define (db:initialize db)
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...

	                        value REAL,
	                        expected REAL,
	                        tol REAL,
                                units TEXT,
                                comment TEXT DEFAULT '',
                                status TEXT DEFAULT 'n/a',
                              CONSTRAINT test_data UNIQUE (test_id,category,variable));")
       (print "WARNING: Table test_data and test_meta where recreated. Please do megatest -update-meta")
       (patch-db))
      ((< mver 1.27)
       (db:set-var db "MEGATEST_VERSION" 1.27)
       (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';")
       (patch-db))
      ((< mver 1.29)
       (db:set-var db "MEGATEST_VERSION" 1.29)

    (sqlite3:for-each-row (lambda (id)
			    (set! ids (cons id ids)))
			  db
			  "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;"
			  run-id test-name (item-list->path itemdat))
    (for-each (lambda (id)
		(sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" id)


		(thread-sleep! 0.1)) ;; give others access to the db
	      ids)))
;;"DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?);" 
		   
;; 
(define (db:delete-test-records db test-id)
  (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id)
  (sqlite3:execute db "DELETE FROM test_data  WHERE test_id=?;" test-id)

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


(define (db:test-set-comment db run-id test-name item-path comment)
  (sqlite3:execute 
   db 
   "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;"
   comment run-id test-name item-path))

;;
(define (db:test-set-rundir! db run-id test-name item-path rundir)
  (sqlite3:execute 
   db 
   "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;"
   rundir run-id test-name item-path))

(define (db:test-set-log! db run-id test-name item-path logf)

  (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" 
		   logf run-id test-name item-path))


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

(define (db:test-get-paths-matching db keynames target)
  (let* ((res '())

		     ((meta-info)
		      (apply sqlite3:execute meta-stmt (vector-ref entry 2)))
		     ((step-status)
		      (apply sqlite3:execute step-stmt (vector-ref entry 2)))
		     (else
		      (debug:print 0 "ERROR: Queued entry not recognised " entry))))
		 data)))


    (set! *incoming-data* '())
    (mutex-unlock! *incoming-mutex*)
    (sqlite3:finalize! meta-stmt)
    (sqlite3:finalize! step-stmt)))

(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")
	       (equal? status "FAIL")
	       (equal? status "WAIVED")
	       (equal? status "RUNNING")))
      (begin
	(sqlite3:execute 
	 db
	 "UPDATE tests 
             SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'),
                 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED'))
             WHERE run_id=? AND testname=? AND item_path='';"
	 run-id test-name run-id test-name run-id test-name)

	(if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING
	    (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name)
	    (sqlite3:execute
	     db
	     "UPDATE tests
                       SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN 
                          'RUNNING'
                       ELSE 'COMPLETED' END,
                          status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END
                       WHERE run_id=? AND testname=? AND item_path='';"
	     run-id test-name run-id test-name)))))




;;======================================================================
;; Tests meta data
;;======================================================================

;; read the record given a testname

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

(define (db:load-test-data db run-id test-name itemdat)
  (let* ((item-path (item-list->path itemdat))
	 (testdat (db:get-test-info db run-id test-name item-path))
	 (test-id (if testdat (db:test-get-id testdat) #f)))
    ;; (debug:print 1 "Enter records to insert in the test_data table, seven fields, comma separated per line")
    (debug:print 4 "itemdat: " itemdat ", test-name: " test-name ", test-id: " test-id)
    (if test-id
	(let loop ((lin (read-line)))
	  (if (not (eof-object? lin))
	      (begin
		(debug:print 4 lin)
		(db:csv->test-data db test-id lin)
		(loop (read-line))))))
    ;; roll up the current results.
    ;; FIXME: Add the status to 
    (db:test-data-rollup db test-id #f)))

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

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

(define (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile)
  (debug:print 4 "run-id: " run-id " test-name: " test-name)
  (let* ((state     (check-valid-items "state" state-in))
	 (status    (check-valid-items "status" status-in))
	 (testdat   (db:get-test-info db run-id test-name item-path)))
    (debug:print 5 "testdat: " testdat)
    (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works.
	     (or (not state)(not status)))
	(debug:print 0 "WARNING: Invalid " (if status "status" "state")
	       " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
    (if testdat
	(let ((test-id (test:get-id testdat)))
	  (mutex-lock! *incoming-mutex*)
	  (set! *incoming-data* (cons (vector 'step-status
					      (current-seconds)
					      ;; FIXME - this should not update the logfile unless it is specified.
					      (list test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile "")))
				      *incoming-data*))
	  (mutex-unlock! *incoming-mutex*)
	  (if (not *cache-on*)(db:write-cached-data db))
	  #t)
	(debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db"))))

;;======================================================================
;; Extract ods file from the db
;;======================================================================

;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )

  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:set-tests-state-status host port)
	 run-id testnames currstate currstatus newstate newstatus))
      (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)))

(define (rdb:teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile)
  (let ((item-path (item-list->path itemdat)))
    (if *runremote*
	(let ((host (vector-ref *runremote* 0))
	      (port (vector-ref *runremote* 1)))
	  ((rpc:procedure 'rdb:teststep-set-status! host port)
	   run-id test-name teststep-name state-in status-in item-path comment logfile))
	(db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile))))

(define (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree)
  (let ((item-path (item-list->path itemdat)))
    (if *runremote*
	(let ((host (vector-ref *runremote* 0))
	      (port (vector-ref *runremote* 1)))
	  ((rpc:procedure 'rdb:test-update-meta-info host port)

  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:roll-up-pass-fail-counts host port)
	 run-id test-name item-path status))
      (db:roll-up-pass-fail-counts db run-id test-name item-path status)))

(define (rdb:test-set-comment db run-id test-name item-path comment)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:test-set-comment host port)
	 run-id test-name item-path comment))
      (db:test-set-comment db run-id test-name item-path comment)))

(define (rdb:test-set-log! db run-id test-name item-path logf)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:test-set-log! host port)
	 run-id test-name item-path logf))
      (db:test-set-log! db run-id test-name item-path logf)))

(define (rdb:get-runs db runnamepatt numruns startrunoffset keypatts)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:get-runs host port)
	 runnamepatt numruns startrunoffset keypatts))

(define (rdb:delete-test-records db test-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:delete-test-records host port) test-id))
      (db:delete-test-records db test-id)))