Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1235,11 +1235,13 @@ (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) (mark-for-update))))) (set! *hide-not-hide-button* hideit) hideit)) (iup:hbox - (iup:button "Quit" #:action (lambda (obj)(if *dbstruct-local* (db:close-all *dbstruct-local*))(exit))) + (iup:button "Quit" #:action (lambda (obj) + ;; (if *dbstruct-local* (db:close-all *dbstruct-local*)) + (exit))) (iup:button "Refresh" #:action (lambda (obj) (mark-for-update))) (iup:button "Collapse" #:action (lambda (obj) (let ((myname (iup:attribute obj "TITLE"))) (if (equal? myname "Collapse") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -238,11 +238,11 @@ (db:initialize-main-db db) (db:initialize-run-id-db db)))) (write-access (file-write-access? dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) - (cons db path))) + (cons db dbpath))) ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) @@ -415,10 +415,14 @@ (begin (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) + (for-each (lambda (dbdat) + (debug:print 0 " dbpath: " (db:dbdat-get-path dbdat))) + (cons todb slave-dbs)) (print-call-chain)) (cond ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1) ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2) ((not (sqlite3:database? (db:dbdat-get-db fromdb))) @@ -455,27 +459,27 @@ ;; read the source table (sqlite3:for-each-row (lambda (a . b) (set! fromdat (cons (apply vector a b) fromdat))) - fromdb + (db:dbdat-get-db fromdb) full-sel) (debug:print-info 2 "found " (length fromdat) " records to sync") ;; read the target table (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) - todb + (db:dbdat-get-db todb) full-sel) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) - (let ((stmth (sqlite3:prepare targdb full-ins)) - (db (db:dbdat-get-db targdb))) + (let* ((db (db:dbdat-get-db targdb)) + (stmth (sqlite3:prepare targdb full-ins))) (db:delay-if-busy targdb) (sqlite3:with-transaction targdb (lambda () (for-each ;; @@ -574,19 +578,18 @@ ;; now ensure all newdb data are synced to megatest.db (if (member 'new2old options) (for-each (lambda (run-id) - (let ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) - (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) + (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) (if (eq? run-id 0) - (db:sync-tables (db:sync-main-list dbstruct)(db:get-db fromdb run-id) mtdb) - (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)))) + (db:sync-tables (db:sync-main-list dbstruct) fromdb mtdb) + (db:sync-tables db:sync-tests-only fromdb mtdb)))) run-ids)) - (db:close-all dbstruct) (sqlite3:finalize! mdb))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) @@ -998,11 +1001,11 @@ (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (key) (set! res (cons key res))) - (db:get-db dbstruct #f) + db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) res))) ;; look up values in a header/data structure @@ -1201,30 +1204,32 @@ (vector header res))) ;; Get all targets from the db ;; (define (db:get-targets dbstruct) - (let* ((dbdat (db:get-db dbstruct)) - (db (db:dbdat-get-db dbdat)) - (res '()) + (let* ((res '()) (keys (db:get-keys dbstruct)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';")) (seen (make-hash-table))) - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (a . x) - (let ((targ (cons a x))) - (if (not (hash-table-ref/default seen targ #f)) - (begin - (hash-table-set! seen targ #t) - (set! res (cons (apply vector targ) res)))))) - db - qrystr) - (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) - (vector header res))) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . x) + (let ((targ (cons a x))) + (if (not (hash-table-ref/default seen targ #f)) + (begin + (hash-table-set! seen targ #t) + (set! res (cons (apply vector targ) res)))))) + db + qrystr) + (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) + (vector header res))))) ;; just get count of runs (define (db:get-num-runs dbstruct runpatt) (db:with-db dbstruct @@ -1258,11 +1263,11 @@ ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... (define (db:get-run-stats dbstruct) - (let* ((dbdat (db:get-db dbstruct)) + (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat)) (totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) @@ -1275,29 +1280,31 @@ "SELECT id,runname FROM runs WHERE state != 'deleted';") ;; for each run get stats data (for-each (lambda (run-info) ;; get the net state/status counts for this run - (let* ((rdbdat (db:get-db dbstruct run-id)) - (rdb (db:dbdat-get-db dbdat)) - (run-id (car run-info)) + (let* ((run-id (car run-info)) (run-name (cadr run-info))) - (db:delay-if-busy rdbdat) - (sqlite3:for-each-row - (lambda (state status count) - (let ((netstate (if (equal? state "COMPLETED") status state))) - (if (string? netstate) - (begin - (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) - (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) - rdb - "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") - ;; add the per run counts to res - (for-each (lambda (state) - (set! res (cons (list run-name state (hash-table-ref curr state)) res))) - (sort (hash-table-keys curr) string>=)) - (set! curr (make-hash-table)))) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (state status count) + (let ((netstate (if (equal? state "COMPLETED") status state))) + (if (string? netstate) + (begin + (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) + (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) + db + "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") + ;; add the per run counts to res + (for-each (lambda (state) + (set! res (cons (list run-name state (hash-table-ref curr state)) res))) + (sort (hash-table-keys curr) string>=)) + (set! curr (make-hash-table)))))) runs-info) (for-each (lambda (state) (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) (sort (hash-table-keys totals) string>=)) res)) @@ -1649,20 +1656,21 @@ (db:general-call db 'delete-test-step-records (list test-id)) ;; (db:delay-if-busy) (db:general-call db 'delete-test-data-records (list test-id)) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) -(define (db:delete-tests-for-run dbdbstruct run-id) - (let ((db (db:get-db dbstruct run-id))) - (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id))) - (define (db:delete-old-deleted-test-records dbstruct) (let ((run-ids (db:get-all-run-ids dbstruct)) (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past (for-each (lambda (run-id) - (sqlite3:execute (db:get-db dbstruct run-id) "DELETE FROM tests WHERE state='DELETED' AND event_timenumber "id" db:test-record-fields)))) - (db:adj-test-id mtdb min-test-id test-id))) + (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) testrecs))) ;; 1. move test ids into the 30k * run_id range ;; 2. move step ids into the 30k * run_id range ;; @@ -1892,96 +1927,123 @@ (define (db:prep-megatest.db-for-migration mtdb) (let* ((run-ids (db:get-all-run-ids mtdb))) (for-each (lambda (run-id) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) - (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs))) + (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) run-ids))) ;; Get test data using test_id (define (db:get-test-info-by-id dbstruct run-id test-id) - (let ((db (db:get-db dbstruct run-id)) - (res #f)) - (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum))) - (db:get-db dbstruct run-id) - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") - test-id) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") + test-id) + res)))) ;; Use db:test-get* to access ;; Get test data using test_ids. NB// Only works within a single run!! ;; (define (db:get-test-info-by-ids dbstruct run-id test-ids) - (let ((db (db:get-db dbstruct run-id)) - (res '())) - (sqlite3:for-each-row - (lambda (a . b) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (cons (apply vector a b) res))) - (db:get-db dbstruct run-id) - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" - (string-intersperse (map conc test-ids) ",") ");")) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . b) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (set! res (cons (apply vector a b) res))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" + (string-intersperse (map conc test-ids) ",") ");")) + res)))) (define (db:get-test-info dbstruct run-id testname item-path) - (let ((db (db:get-db dbstruct run-id)) - (res #f)) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (apply vector a b))) - (db:get-db dbstruct run-id) - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") - test-name item-path) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (apply vector a b))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") + test-name item-path) + res)))) (define (db:test-get-rundir-from-test-id dbstruct run-id test-id) - (db:first-result-default - (db:get-db dbstruct run-id) - "SELECT rundir FROM tests WHERE id=?;" - #f ;; default result - test-id)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (db:first-result-default + db + "SELECT rundir FROM tests WHERE id=?;" + #f ;; default result + test-id)))) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) - (let ((db (db:get-db dbstruct run-id))) - (sqlite3:execute - db - "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" - test-id teststep-name state-in status-in (current-seconds) - ;; (sdb:qry 'getid - (if comment comment "") ;; ) - ;; (sdb:qry 'getid - (if logfile logfile "")))) ;; ) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute + db + "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" + test-id teststep-name state-in status-in (current-seconds) + (if comment comment "") + (if logfile logfile ""))))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test dbstruct run-id test-id) - (let* ((db (db:get-db dbstruct run-id)) - (res '())) - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) - db - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (reverse res))) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let* ((res '())) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (reverse res))))) (define (db:get-steps-data dbstruct run-id test-id) - (let ((db (db:get-db dbstruct run-id)) - (res '())) - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) - db - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (reverse res))) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== @@ -1989,33 +2051,36 @@ ;; 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 dbstruct run-id test-id status) - (let ((db (db:get-db dbstruct run-id)) - (fail-count 0) - (pass-count 0)) + (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) (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;" test-id test-id) ;; Now rollup the counts to the central megatest.db - (db:general-call db 'pass-fail-counts (list pass-count fail-count test-id)) + (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. - (db:general-call db 'test_data-pf-rollup (list test-id test-id test-id test-id)))) + (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((db (db:get-db dbstruct run-id)) - (csvlist (csv->list (make-csv-reader - (open-input-string csvdata) - '((strip-leading-whitespace? #t) - (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) + (csvlist (csv->list (make-csv-reader + (open-input-string csvdata) + '((strip-leading-whitespace? #t) + (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) (for-each (lambda (csvrow) (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) (category (list-ref padded-row 0)) (variable (list-ref padded-row 1)) @@ -2059,28 +2124,31 @@ ((>=) (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) (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:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) - (let* ((row-ids '()) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get dbdat)) + (row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) - (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) + (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) @@ -2088,27 +2156,37 @@ row-ids)) (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) - (sqlite3:for-each-row - (lambda (p) - (set! res (cons p res))) - (db:get-db dbstruct run-id) - tstsqry) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (p) + (set! res (cons p res))) + db + tstsqry) + res)))) (define (db:test-toplevel-num-items dbstruct run-id testname) - (let ((res 0)) - (sqlite3:for-each-row - (lambda (num-items) - (set! res num-items)) - (db:get-db dbstruct run-id) - "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" - run-id - testname) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (num-items) + (set! res num-items)) + db + "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" + run-id + testname) + res)))) ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== @@ -2141,55 +2219,58 @@ (vector #f #f #f))) ;; crude reply for when things go awry ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) (define (db:test-set-status-state dbstruct run-id test-id status state msg) - (let ((db (db:get-db dbstruct run-id))) - (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (db:general-call db 'set-test-start-time (list test-id))) - (if msg - (db:general-call db 'state-status-msg (list state status msg test-id)) - (db:general-call db 'state-status (list state status test-id))))) + (let ((dbdat (db:get-db dbstruct run-id))) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (db:general-call dbdat 'set-test-start-time (list test-id))) + (if msg + (db:general-call dbdat 'state-status-msg (list state status msg test-id)) + (db:general-call dbdat 'state-status (list state status test-id))))) (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP" "LAUNCHED"))) - (let ((db (db:get-db dbstruct run-id))) - (db:general-call db 'update-pass-fail-counts (list test-name test-name test-name)) + (let ((dbdat (db:get-db dbstruct run-id))) + (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) (if (equal? status "RUNNING") - (db:general-call db 'top-test-set-running (list test-name)) + (db:general-call dbdat 'top-test-set-running (list test-name)) (if (equal? status "LAUNCHED") - (db:general-call db 'top-test-set (list "LAUNCHED" test-name)) - (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) + (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)) + (db:general-call dbdat 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) #f) #f)) (define (db:tests-register-test dbstruct run-id test-name item-path) - (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path)) -;; (let ((sleep-time (random 20)) -;; (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) -;; (case err-status -;; ((busy)(thread-sleep! 4)) -;; (else -;; (debug:print 0 "WARNING: possible problem with call to cdb:remote-run, database may be read-only and locked, waiting and trying again ...") -;; (thread-sleep! sleep-time))) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute db 'register-test run-id test-name item-path)))) (define (db:test-get-logfile-info dbstruct run-id test-name) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (path final_logf) - ;; (let ((path (sdb:qry 'getstr path-id)) - ;; (final_logf (sdb:qry 'getstr final_logf-id))) - (set! logf final_logf) - (set! res (list path final_logf)) - (if (directory? path) - (debug:print 2 "Found path: " path) - (debug:print 2 "No such path: " path))) ;; ) - (db:get-db dbstruct run-id) - "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" - test-name) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (path final_logf) + ;; (let ((path (sdb:qry 'getstr path-id)) + ;; (final_logf (sdb:qry 'getstr final_logf-id))) + (set! logf final_logf) + (set! res (list path final_logf)) + (if (directory? path) + (debug:print 2 "Found path: " path) + (debug:print 2 "No such path: " path))) ;; ) + db + "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" + test-name) + res)))) ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== @@ -2286,33 +2367,36 @@ (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) -(define (db:general-call db stmtname params) +(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)))) - (apply sqlite3:execute db query params) - #t)) + (db:delay-if-busy dbdat) + (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* ((db (db:get-db dbstruct #f)) + (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) (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) @@ -2346,40 +2430,15 @@ (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)))))))))) -;; (let* ((remtries 10) -;; (proc #f)) -;; (set! proc (lambda (remtries) -;; (if (> remtries 0) -;; (handle-exceptions -;; exn -;; (let ((sleep-time (random 30)) -;; (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) -;; (case err-status -;; ((busy) -;; (thread-sleep! sleep-time) -;; (proc 10)) ;; we never give up on busy -;; (else -;; (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") -;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) -;; (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) -;; (print-call-chain) -;; (debug:print 0 "Sleeping for " sleep-time) -;; (thread-sleep! sleep-time) -;; (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up") -;; (proc (- remtries 1))))) -;; (apply sqlite3:execute db query params)) -;; (debug:print 0 "ERROR: too many attempts to access db were made and no sucess. query: " -;; query ", params: " params)))) -;; (proc remtries)) + (define (db:delay-if-busy dbdat #!key (count 6)) (if dbdat (let* ((dbpath (db:dbdat-get-path dbdat)) (dbfj (conc dbpath "-journal"))) -;; (conc *toppath* "/megatest.db-journal")))) (if (file-exists? dbfj) (case count ((6) (thread-sleep! 0.2) (db:delay-if-busy count: 5)) @@ -2399,57 +2458,72 @@ (thread-sleep! 6.4) (db:delay-if-busy count: 0)) (else (debug:print-info 0 "delaying db access due to high database load.") (thread-sleep! 12.8))))))) -;; (db:delay-if-busy) -;; (apply sqlite3:execute db query params))) -;; (db:delay-if-busy) (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) - (sqlite3:for-each-row - (lambda (id itempath state status run_duration logf comment) - (set! res (cons (vector id itempath state status run_duration logf comment) res))) - (db:get-db dbstruct run-id) - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" - test-name) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id itempath state status run_duration logf comment) + (set! res (cons (vector id itempath state status run_duration logf comment) res))) + db + "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" + test-name) + res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) (let ((res #f)) - (sqlite3:for-each-row - (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) - (db:get-db dbstruct #f) - "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" - testname) - res)) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) + (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) + db + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" + testname) + res)))) ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) - (db:delay-if-busy) - (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:execute + db + "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)))) ;; update one of the testmeta fields (define (db:testmeta-update-field dbstruct testname field value) - (db:delay-if-busy) - (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:execute + db + (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) (define (db:testmeta-get-all dbstruct) - (let ((res '())) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (cons (apply vector a b) res))) - (db:get-db dbstruct run-id) - "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") - res)) + (db:with-db dbstruct #f #f + (lambda (db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (cons (apply vector a b) res))) + db + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") + res)))) ;;====================================================================== ;; M I S C M A N A G E M E N T I T E M S ;;======================================================================