Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -197,21 +197,21 @@ (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (rdb:test-set-state-status-by-id *db* 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) - (rdb:test-set-state-status-by-id *db* 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) @@ -227,11 +227,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) - (rdb:test-set-state-status-by-id *db* 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")))) (vector-set! *state-status* 1 (lambda (status color) @@ -246,33 +246,34 @@ ;;====================================================================== ;; ;;====================================================================== -(define (examine-test db test-id) ;; run-id run-key origtest) - (let* ((testdat (db:get-test-info-by-id db test-id)) +(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")) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) - (request-update #t)) + (request-update #t) + (db #f)) (if (not testdat) (begin (debug:print 0 "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 (db:get-key-val-pairs db run-id) #f)) - (rundat (if testdat (db:get-run-info db 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)) ;(teststeps (if testdat (db:get-steps-for-test db test-id) #f)) (logfile "/this/dir/better/not/exist") (rundir logfile) (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 (db:testmeta-get-record db 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) @@ -297,15 +298,15 @@ (refreshdat (lambda () (let* ((curr-mod-time (file-modification-time db-path)) (need-update (or (and (> curr-mod-time db-mod-time) (> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched request-update)) - (newtestdat (if need-update (db:get-test-info-by-id db test-id)))) + (newtestdat (if need-update (open-run-close db:get-test-info-by-id db test-id)))) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (rdb:get-steps-for-test db test-id)) + (set! teststeps (open-run-close db:get-steps-for-test db test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat))) (need-update ;; if this was true and yet there is no data .... (db:test-set-testname! testdat "DEAD OR DELETED TEST")))))) @@ -400,11 +401,11 @@ #:size "60x100"))) (hash-table-set! widgets "Test Steps" (lambda (testdat) (let* ((currval (iup:attribute stepsdat "VALUE")) ;; "TITLE")) (fmtstr "~20a~10a~10a~12a~15a~20a") - (comprsteps (rdb:get-steps-table db test-id)) + (comprsteps (open-run-close db:get-steps-table db test-id)) (newval (string-intersperse (append (list (format #f fmtstr "Stepname" "Start" "End" "Status" "Time" "Logfile") (format #f fmtstr "========" "=====" "===" "======" "====" "=======")) @@ -458,11 +459,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))) - (db:read-test-data db 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))) ))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -75,30 +75,30 @@ (if (not (setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *db* (open-db)) +(define *db* #f) ;; (open-db)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (server:client-setup *db*) (define toplevel #f) (define dlg #f) (define max-test-num 0) -(define *keys* (rdb:get-keys *db*)) +(define *keys* (open-run-close db:get-keys *db*)) ;; (define *keys* (db:get-keys *db*)) (define *dbkeys* (map (lambda (x)(vector-ref x 0)) (append *keys* (list (vector "runname" "blah"))))) (define *header* #f) (define *allruns* '()) (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) -(define *tot-run-count* (rdb:get-num-runs *db* "%")) +(define *tot-run-count* (open-run-close db:get-num-runs *db* "%")) ;; (define *tot-run-count* (db:get-num-runs *db* "%")) (define *last-update* (current-seconds)) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) @@ -166,11 +166,11 @@ (begin (debug:print 4 "INFO: update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " itemnamepatt: " itemnamepatt " keypatts: " keypatts) (set! *please-update-buttons* #t) (set! *last-db-update-time* modtime) (set! *delayed-update* (- *delayed-update* 1)) - (let* ((allruns (rdb:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (let* ((allruns (open-run-close db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) @@ -181,13 +181,13 @@ (begin (set! *last-update* (current-seconds)) (set! *tot-run-count* (length runs)))) ;; (rdb:get-num-runs *db* runnamepatt)))) (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (let ((tsts (rdb:get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses))) + (tests (let ((tsts (open-run-close db:get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses))) (if *tests-sort-reverse* (reverse tsts) tsts))) - (key-vals (rdb:get-key-vals *db* run-id))) + (key-vals (open-run-close db:get-key-vals *db* run-id))) (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set (not (null? tests))) (set! result (cons (vector run tests key-vals) result))))) @@ -637,18 +637,18 @@ (if runid (begin (lambda (x) (on-exit (lambda () (sqlite3:finalize! *db*))) - (examine-run *db* runid))) + (open-run-close examine-run *db* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") (let ((testid (string->number (args:get-arg "-test")))) (if testid - (examine-test *db* testid) + (examine-test testid) (begin (print "ERROR: testid is not a number " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -45,15 +45,15 @@ 36000)))) ;; 136000))) (debug:print 4 "INFO: dbpath=" dbpath) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) - ;; (if (config-lookup *configdat* "setup" "synchronous") - ;; (begin - ;; (debug:print 4 "INFO: Turning off pragma synchronous") - ;; (sqlite3:execute db "PRAGMA synchronous = 0;")) - ;; (debug:print 4 "INFO: NOT turning off pragma synchronous")) + (if (config-lookup *configdat* "setup" "synchronous") + (begin + (debug:print 5 "INFO: Turning off pragma synchronous") + (sqlite3:execute db "PRAGMA synchronous = 0;")) + (debug:print 5 "INFO: NOT turning off pragma synchronous")) db)) (define (open-run-close proc idb . params) (let* ((db (if idb idb (open-db))) (res (apply proc db params))) @@ -604,13 +604,19 @@ (define (db:delete-tests-in-state db run-id state) (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id)) (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) - (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) - (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) - (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))) + (cond + ((and newstate newstatus newcomment) + (sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id)) + ((and newstate newstatus) + (sqlite3:exectute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) + (else + (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) + (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) + (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))) (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" state status run-id test-name item-path)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -152,11 +152,11 @@ (if waived (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) - (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path real-status state)) + (db:test-set-state-status-by-run-id-testname db run-id test-name item-path real-status state)) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, do not rpc it (yet) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup db test-id status)) @@ -191,21 +191,21 @@ expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) - (rdb:csv->test-data db test-id + (db:csv->test-data db test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest - (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) + (db:roll-up-pass-fail-counts db run-id test-name item-path status) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (rdb:test-set-comment db test-id cmt))) + (db:test-set-comment db test-id cmt))) )) (define (test-set-toplog! db run-id test-name logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" logf run-id test-name))