Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -193,34 +193,36 @@ (let* ((state (db:test-get-state testdat)) (status (db:test-get-status testdat)) (color (car (gutils:get-color-for-state-status state status)))) ((vector-ref *state-status* 0) state color) ((vector-ref *state-status* 1) status color))) + +(define *dashboard-test-db* #t) ;;====================================================================== ;; Set fields ;;====================================================================== -(define (set-fields-panel test-id testdat) +(define (set-fields-panel test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) (newstate #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (open-run-close db:test-set-state-status-by-id #f test-id #f #f b) + (open-run-close db:test-set-state-status-by-id db test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL")) (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id #f test-id state #f #f) + (open-run-close db:test-set-state-status-by-id db test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -236,11 +238,11 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id #f test-id #f status #f) + (open-run-close db:test-set-state-status-by-id db test-id #f status #f) (db:test-set-status! testdat status))))) btn)) (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) @@ -289,23 +291,23 @@ ;;====================================================================== ;; ;;====================================================================== (define (examine-test test-id) ;; run-id run-key origtest) - (let* ((testdat (open-run-close db:get-test-info-by-id #f test-id)) - (db-path (conc *toppath* "/megatest.db")) + (let* ((db-path (conc *toppath* "/megatest.db")) + (db (open-db)) + (testdat (open-run-close db:get-test-info-by-id db test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) - (request-update #t) - (db #f)) + (request-update #t)) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* ((run-id (if testdat (db:test-get-run_id testdat) #f)) - (keydat (if testdat (open-run-close db:get-key-val-pairs #f run-id) #f)) - (rundat (if testdat (open-run-close db:get-run-info #f run-id) #f)) + (keydat (if testdat (open-run-close db:get-key-val-pairs db run-id) #f)) + (rundat (if testdat (open-run-close db:get-run-info db run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "runname") #f)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. @@ -314,11 +316,11 @@ (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (db:get-compressed-steps test-id work-area: rundir) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat - (let ((tm (open-run-close db:testmeta-get-record #f testname))) + (let ((tm (open-run-close db:testmeta-get-record db testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -361,11 +363,11 @@ request-update)) (newtestdat (if need-update (handle-exceptions exn (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) - (open-run-close db:get-test-info-by-id #f test-id ))))) + (open-run-close db:get-test-info-by-id db test-id ))))) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (db:get-compressed-steps test-id work-area: rundir)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) @@ -601,11 +603,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (open-run-close db:read-test-data #f test-id "%"))) + (open-run-close db:read-test-data db test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -261,11 +261,11 @@ (handle-exceptions exn (begin (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) - #f) + (set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access (set! db (sqlite3:open-database dbpath))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = FULL;") @@ -2178,14 +2178,14 @@ ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) (< (db:step-get-id a) (db:step-get-id b))) (else #f))))) res))) -(define (db:get-compressed-steps test-id #!key (work-area #f)) +(define (db:get-compressed-steps test-id #!key (work-area #f)(tdb #f)) (if (or (not work-area) (file-exists? (conc work-area "/testdat.db"))) - (let* ((comprsteps (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (let* ((comprsteps (open-run-close db:get-steps-table tdb test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) (let ((s (vector-ref x 1)))