Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -349,36 +349,98 @@ ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* - '((0 "COMPLETED") - (1 "NOT_STARTED") - (2 "RUNNING") - (3 "REMOTEHOSTSTART") - (4 "LAUNCHED") + '((0 "RUNNING") + (1 "COMPLETED") + (2 "REMOTEHOSTSTART") + (3 "LAUNCHED") + (4 "NOT_STARTED") (5 "KILLED") (6 "KILLREQ") (7 "STUCK") (8 "ARCHIVED"))) (define *common:std-statuses* - '((0 "PASS") - (1 "WARN") - (2 "FAIL") + '((0 "DELETED") + (1 "n/a") + (2 "PASS") (3 "CHECK") - (4 "n/a") - (5 "WAIVED") - (6 "SKIP") - (7 "DELETED") - (8 "STUCK/DEAD") + (4 "SKIP") + (5 "WARN") + (6 "WAIVED") + (7 "STUCK/DEAD") + (8 "FAIL") (9 "ABORT"))) + +(define (common:special-sort items order comp) + (let ((items-order (map reverse order)) + (acomp (or comp >))) + (sort items + (lambda (a b) + (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) + (b-num (cadr (or (assoc b items-order) '(0 0))))) + (acomp a-num b-num)))))) ;; These are stopping conditions that prevent a test from being run (define *common:cant-run-states-sym* '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED)) +;; given a toplevel with currstate, currstatus apply state and status +;; => (newstate . newstatus) +(define (common:apply-state-status currstate currstatus state status) + (let* ((cstate (string->symbol (string-downcase currstate))) + (cstatus (string->symbol (string-downcase currstatus))) + (sstate (string->symbol (string-downcase state))) + (sstatus (string->symbol (string-downcase status))) + (nstate #f) + (nstatus #f)) + (set! nstate + (case cstate + ((completed not_started killed killreq stuck archived) + (case sstate ;; completed -> sstate + ((completed killed killreq stuck archived) completed) + ((running remotehoststart launched) running) + (else unknown-error-1))) + ((running remotehoststart launched) + (case sstate + ((completed killed killreq stuck archived) #f) ;; need to look at all items + ((running remotehoststart launched) running) + (else unknown-error-2))) + (else unknown-error-3))) + (set! nstatus + (case sstatus + ((pass) + (case nstate + ((pass n/a deleted) pass) + ((warn) warn) + ((fail) fail) + ((check) check) + ((waived) waived) + ((skip) skip) + ((stuck/dead) stuck) + ((abort) abort) + (else unknown-error-4))) + ((warn) + (case nstate + ((pass warn n/a skip deleted) warn) + ((fail) fail) + ((check) check) + ((waived) waived) + ((stuck/dead) stuck) + (else unknown-error-5))) + ((fail) + (case nstate + ((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail) + ((abort) abort) + (else unknown-error-6))) + (else unknown-error-7))) + (cons + (if nstate (symbol->string nstate) nstate) + (if nstatus (symbol->string nstatus) nstatus)))) + ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== (define *verbosity* 1) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -41,11 +41,12 @@ ;;====================================================================== ;; each db entry is a pair ( db . dbfilepath ) (defstruct dbr:dbstruct (tmpdb #f) - (mtdb #f)) + (mtdb #f) + (refndb #f)) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== @@ -106,11 +107,11 @@ ;; (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds)) ;; (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds))) ;; (dbr:dbstruct-inuse-set! dbstruct #f) ;; (mutex-unlock! *rundb-mutex*)))) -;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") +;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) (let* ((dbdat (if (dbr:dbstruct? dbstruct) (db:get-db dbstruct run-id) @@ -247,24 +248,26 @@ ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; -(define (db:open-db dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (db:open-db dbstruct #!key (areapath #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))) ;; RA => Returns the first reference in dbstruct (if tmpdb tmpdb ;; (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path)) ;; 0)) (dbexists (file-exists? dbpath)) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (mtdb (db:open-megatest-db)) + (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) (write-access (file-write-access? dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (dbr:dbstruct-mtdb-set! dbstruct mtdb) (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) ;; olddb is already a (cons db path) + (dbr:dbstruct-refndb-set! dbstruct refndb) ;; (mutex-unlock! *rundb-mutex*) (if (and (not dbexists) *db-write-access*) ;; did not have a prior db and do have write access (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically tmpdb)))) @@ -271,14 +274,14 @@ ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; -(define (db:setup) ;; . junk) ;; #!key (run-id #f) (local #f)) +(define (db:setup #!key (areapath #f)) ;; . junk) ;; #!key (run-id #f) (local #f)) (let* (;; (dbdir (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct))) ;; ) ;; path: dbdir local: local))) - (db:open-db dbstruct) + (db:open-db dbstruct areapath: #f) dbstruct)) ;; open the local db for direct access (no server) ;; (define (db:open-local-db-handle) @@ -289,12 +292,12 @@ ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; -(define (db:open-megatest-db #!key (path #f)) - (let* ((dbpath (conc (or path *toppath*) "/megatest.db")) +(define (db:open-megatest-db #!key (path #f)(name #f)) + (let* ((dbpath (conc (or path *toppath*) "/" (or name "megatest.db"))) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) (db:initialize-run-id-db db)))) @@ -310,17 +313,18 @@ ;; (stime (dbr:dbstruct-stime dbstruct)) ;; (rundb (dbr:dbstruct-rundb dbstruct)) ;; (inmem (dbr:dbstruct-inmem dbstruct)) ;; (maindb (dbr:dbstruct-main dbstruct)) ;; (refdb (dbr:dbstruct-refdb dbstruct)) - (tmpdb (dbr:dbstruct-tmpdb dbstruct)) - (mtdb (dbr:dbstruct-mtdb dbstruct)) + (tmpdb (dbr:dbstruct-tmpdb dbstruct)) + (mtdb (dbr:dbstruct-mtdb dbstruct)) + (refndb (dbr:dbstruct-refndb dbstruct)) ;; (runid (dbr:dbstruct-run-id dbstruct)) ) (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) ;; (mutex-lock! *http-mutex*) - (db:sync-tables (db:sync-all-tables-list tmpdb) #f tmpdb mtdb))) + (db:sync-tables (db:sync-all-tables-list tmpdb) #f tmpdb refndb mtdb))) ;; (if (eq? run-id 0) ;; ;; runid equal to 0 is main.db ;; (if maindb ;; (if (or (not (number? mtime)) ;; (not (number? stime)) @@ -374,14 +378,16 @@ ;; close all opened run-id dbs (define (db:close-all dbstruct) (if (dbr:dbstruct? dbstruct) (begin (db:sync-touched dbstruct 0 force-sync: #t) - (let ((tdb (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) - (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))) + (let ((tdb (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) + (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) + (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) (if tdb (sqlite3:finalize! tdb)) - (if mdb (sqlite3:finalize! mdb)))))) + (if mdb (sqlite3:finalize! mdb)) + (if rdb (sqlite3:finalize! rdb)))))) ;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) ;; (if (hash-table? locdbs) ;; (for-each (lambda (run-id) ;; (db:close-run-db dbstruct run-id)) @@ -709,11 +715,11 @@ (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count))) (mutex-unlock! *db-sync-mutex*))) -(define (db:patch-schema-rundb run-id frundb) +(define (db:patch-schema-rundb frundb) ;; ;; remove this some time after September 2016 (added in version v1.6031 ;; (for-each (lambda (table-name) @@ -737,19 +743,19 @@ WHERE id=old.id; END;")) ) '("tests" "test_steps" "test_data"))) -(define (db:patch-schema-maindb run-id maindb) +(define (db:patch-schema-maindb maindb) ;; ;; remove all these some time after september 2016 (added in v1.6031 ;; (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "Column last_update already added to runs table") - (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none")) + (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) (sqlite3:execute maindb "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) ;; these schema changes don't need exception handling (sqlite3:execute @@ -857,10 +863,11 @@ (if (not (launch:setup)) (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") (let* ((dbstruct (db:setup)) (mtdb (dbr:dbstruct-mtdb dbstruct)) (tmpdb (dbr:dbstruct-tmpdb dbstruct)) + (refndb (dbr:dbstruct-refndb dbstruct)) (allow-cleanup (if run-ids #f #t)) ;; (run-ids (if run-ids ;; run-ids ;; (db:get-all-run-ids mtdb))) (tdbdat (tasks:open-db)) @@ -876,13 +883,14 @@ ;; clear out junk records ;; (if (member 'dejunk options) (begin - (db:delay-if-busy mtdb) + (db:delay-if-busy mtdb) ;; ok to delay on mtdb (db:clean-up mtdb) - (db:clean-up tmpdb))) + (db:clean-up tmpdb) + (db:clean-up refndb))) ;; adjust test-ids to fit into proper range ;; ;; (if (member 'adj-testids options) ;; (begin @@ -891,11 +899,11 @@ ;; sync runs, test_meta etc. ;; (if (member 'old2new options) ;; (begin - (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb)) + (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)) ;; (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) ;; (for-each ;; (lambda (run-id) ;; (db:delay-if-busy mtdb) ;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) @@ -907,11 +915,21 @@ ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; (if (member 'new2old options) - (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb mtdb)) + (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)) + + (if (member 'fixschema options) + (begin + (db:patch-schema-maindb (db:dbdat-get-db mtdb)) + (db:patch-schema-maindb (db:dbdat-get-db tmpdb)) + (db:patch-schema-maindb (db:dbdat-get-db refndb)) + (db:patch-schema-rundb (db:dbdat-get-db mtdb)) + (db:patch-schema-rundb (db:dbdat-get-db tmpdb)) + (db:patch-schema-rundb (db:dbdat-get-db refndb)))) + ;; (let* ((maindb (make-dbr:dbstruct path: toppath local: #t)) ;; (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0))))) ;; (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <)) ;; (count 1) ;; (total (length all-run-ids)) @@ -1416,11 +1434,11 @@ ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1432,11 +1450,11 @@ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1480,11 +1498,11 @@ ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1496,11 +1514,11 @@ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1512,11 +1530,11 @@ (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. ;; - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (let* (;; (min-incompleted (filter (lambda (x) ;; (let* ((testpath (cadr x)) ;; (tdatpath (conc testpath "/testdat.db")) ;; (dbexists (file-exists? tdatpath))) ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete @@ -1533,19 +1551,19 @@ (string-intersperse (map conc all-ids) ",") ");"))))) ;; Now do rollups for the toplevel tests ;; - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (for-each (lambda (toptest) (let ((test-name (list-ref toptest 3))) ;; (run-id (list-ref toptest 5))) (db:top-test-set-per-pf-counts dbstruct run-id test-name))) toplevels))) -;; BUG: Possibly broken - does not explicitly use run-id in the query +;; BUG: Probably broken - does not explicitly use run-id in the query ;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) (db:general-call (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) @@ -1577,11 +1595,11 @@ ;; delete all runs that are state='deleted' "DELETE FROM runs WHERE state='deleted';" ;; delete empty runs "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" )))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) @@ -1591,11 +1609,11 @@ (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1618,11 +1636,11 @@ ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" )))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) @@ -1632,11 +1650,11 @@ (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1665,11 +1683,11 @@ (sqlite3:for-each-row (lambda (run-id) (set! dead-runs (cons run-id dead-runs))) db "SELECT id FROM runs WHERE state='deleted';") - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) @@ -1679,11 +1697,11 @@ (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;") dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S @@ -1837,23 +1855,23 @@ (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 *default-log-port* "qry: " qry) qry) qryvals) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) @@ -2041,11 +2059,11 @@ (totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats @@ -2138,11 +2156,11 @@ (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") @@ -2166,15 +2184,15 @@ ;; First set any related tests to DELETED (let* ((rdbdat (db:get-db dbstruct run-id)) (rdb (db:dbdat-get-db rdbdat)) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy rdbdat) + ;; (db:delay-if-busy rdbdat) (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';") (sqlite3:execute rdb "DELETE FROM test_steps;") (sqlite3:execute rdb "DELETE FROM test_data;") - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) (define (db:update-run-event_time dbstruct run-id) (db:with-db dbstruct @@ -2199,11 +2217,11 @@ (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (if msg (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) (define (db:get-run-status dbstruct run-id) @@ -2233,11 +2251,11 @@ (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) db qry run-id))) keys) @@ -2250,11 +2268,11 @@ (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) @@ -2522,11 +2540,11 @@ (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 ;; (sdb:qry 'getid newcomment) test-id)))) (mt:process-triggers run-id test-id newstate newstatus)))) -;; NEW BEHAVIOR: Count tests running in only one run! +;; NEW BEHAVIOR: Count tests running in all runs! ;; (define (db:get-count-tests-running dbstruct run-id) (db:with-db dbstruct run-id @@ -2586,11 +2604,11 @@ (db (db:dbdat-get-db dbdat))) (if (not jobgroup) 0 ;; (let ((testnames '())) ;; get the testnames - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (testname) (set! testnames (cons testname testnames))) db "SELECT testname FROM test_meta WHERE jobgroup=?" @@ -2689,11 +2707,11 @@ (let* ((dbdat (if (vector? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; still settling on when to use dbstruct or dbdat (db (db:dbdat-get-db dbdat)) (res '())) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) res))) @@ -2795,11 +2813,11 @@ 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) +(define (db:get-test-info dbstruct run-id test-name item-path) (db:with-db dbstruct run-id #f (lambda (db) @@ -2806,11 +2824,11 @@ (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=? AND run-id=?;") + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") test-name item-path run-id) res)))) (define (db:test-get-rundir-from-test-id dbstruct run-id test-id) (db:with-db @@ -2884,11 +2902,11 @@ (define (db:test-data-rollup dbstruct run-id test-id status) (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) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) db @@ -3034,11 +3052,11 @@ ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - (db:delay-if-busy dbdat) + ;; (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))) ;; This routine moved from tdb.scm, tdb:read-test-data @@ -3045,11 +3063,11 @@ ;; (define (db:read-test-data dbstruct run-id test-id categorypatt) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (res '())) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (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) @@ -3153,38 +3171,88 @@ (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))) (mt:process-triggers run-id test-id state status))) +;; state is the priority rollup of all states +;; status is the priority rollup of all completed states +;; +(define (db:roll-up-items-state-status dbstruct run-id test-name item-path state status) + (let* ((db (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) + (testdat (db:get-test-info dbstruct run-id test-name "")) + (test-id (db:test-get-id testdat))) + (sqlite3:with-transaction + db + (lambda () + (let* ((all-curr-states (common:special-sort + (cons state (db:get-all-item-states db run-id test-name)) + *common:std-states* >)) + (all-curr-statuses (common:special-sort + (let ((statuses (db:get-all-item-statuses db run-id test-name))) + (if (equal? state "COMPLETED") + (cons status statuses) + statuses)) + *common:std-statuses* >)) + (newstate (car all-curr-states)) + (newstatus (car all-curr-statuses))) + (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus #f)))))) + +(define db:roll-up-pass-fail-counts db:roll-up-items-state-status) + ;; call with state = #f to roll up with out accounting for state/status of this item ;; -(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status) - (if (not (equal? item-path "")) - (let ((dbdat (db:get-db dbstruct run-id))) - ;; (db (db:dbdat-get-db dbdat))) - (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) - (db:top-test-set-per-pf-counts dbstruct run-id test-name)))) - -;; (case (string->symbol status) -;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) -;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) -;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) - -;; (if (or (not state) -;; (not (equal? item-path ""))) -;; ;; just do a rollup -;; (begin -;; (db:top-test-set-per-pf-counts dbdat run-id test-name) -;; #f) -;; (begin -;; ;; NOTE: No else clause needed for this case -;; (case (string->symbol status) -;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) -;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) -;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) -;; #f) -;; ))) +;; (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status) +;; (if (not (equal? item-path "")) ;; if asked to do this for a specific item then do an incremental update +;; (let* ((dbdat (db:get-db dbstruct run-id)) +;; (toptestdat (db:get-test-info dbstruct run-id test-name item-path)) +;; (currtopstate (db:test-get-state toptestdat)) +;; (currtopstatus (db:test-get-status toptestdat)) +;; (nextss (common:apply-state-status currtopstate currtopstatus state status)) +;; (newtopstate (car nextss)) ;; #f or a symbol +;; (newtopstatus (cdr nextss))) ;; #f or a symbol +;; (if (not newtopstate) ;; need to calculate it +;; +;; ;; We rely on the toplevel to track status as state varies. I.e. preserve an ABORT +;; +;; +;; ;; (db (db:dbdat-get-db dbdat))) +;; (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) +;; (db:top-test-set-per-pf-counts dbstruct run-id test-name)))) +;; +;; ;; (case (string->symbol status) +;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) +;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) +;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) +;; +;; ;; (if (or (not state) +;; ;; (not (equal? item-path ""))) +;; ;; ;; just do a rollup +;; ;; (begin +;; ;; (db:top-test-set-per-pf-counts dbdat run-id test-name) +;; ;; #f) +;; ;; (begin +;; ;; ;; NOTE: No else clause needed for this case +;; ;; (case (string->symbol status) +;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) +;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) +;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) +;; ;; #f) +;; ;; ))) + +(define (db:get-all-item-states db run-id test-name) + (sqlite3:map-row + (lambda (a) a) + db + "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?" + run-id test-name)) + +(define (db:get-all-item-statuses db run-id test-name) + (sqlite3:map-row + (lambda (a) a) + db + "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?" + run-id test-name)) (define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id @@ -3245,11 +3313,11 @@ '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") ;; stuff for roll-up-pass-fail-counts '(update-pass-fail-counts "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')), pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id + WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id '(top-test-set "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id ;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this: @@ -3377,11 +3445,11 @@ (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) #t)) ;; get a summary of state and status counts to calculate a rollup ;; @@ -3435,11 +3503,11 @@ (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) 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) + ;; (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)