Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -46,10 +46,13 @@ (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here (define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here +(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id +(define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db + (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define (get-with-default val default) (let ((val (args:get-arg val))) (if val val default))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -247,22 +247,22 @@ ;;====================================================================== ;; ;;====================================================================== (define (examine-test db test-id) ;; run-id run-key origtest) - (let* ((testdat (rdb:get-test-data-by-id db test-id)) + (let* ((testdat (db:get-test-info-by-id db 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)) (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 (rdb:get-key-val-pairs db run-id) #f)) - (rundat (if testdat (rdb:get-run-info db run-id) #f)) + (keydat (if testdat (db:get-key-val-pairs db run-id) #f)) + (rundat (if testdat (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") @@ -297,11 +297,11 @@ (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 (rdb:get-test-data-by-id db test-id)))) + (newtestdat (if need-update (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! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1,6 +1,6 @@ -k;;====================================================================== +;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; 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 on pragma synchronous") - (sqlite3:execute db "PRAGMA synchronous = 0;")) - (debug:print 4 "INFO: NOT turning on pragma synchronous")) + ;; (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")) db)) (define (db:initialize db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (config-get-fields configdat)) @@ -172,11 +172,11 @@ (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print 0 "Initialized test database " dbpath) (db:testdb-initialize db))) - (sqlite3:execute db "PRAGMA synchronous = 0;") + ;; (sqlite3:execute db "PRAGMA synchronous = 0;") db) #f)) ;; find and open the testdat.db file for an existing test (define (db:open-test-db-by-test-id db test-id) @@ -190,12 +190,13 @@ (list "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, - diskusage INTGER DEFAULT -1);" - "CREATE TABLE IF NOT EXISTS test_data ( + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);" + "CREATE TABLE IF NOT EXISTS test_data ( id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, @@ -638,36 +639,83 @@ (set! res count)) db ;; NB// KILLREQ means the jobs is still probably running "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;" run-id) res)) -;; NB// Sync this with runs:get-test-info -(define (db:get-test-info db run-id testname item-path) - (let ((res #f)) +;; map run-id, testname item-path to test-id +(define (db:get-test-id db run-id testname item-path) + (let* ((test-key (conc run-id "-" testname "-" item-path)) + (res (hash-table-ref/default *test-ids* test-key #f))) + (if res + res + (begin + (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 ) + (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment ))) + db + "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;" + run-id testname item-path) + (hash-table-set! *test-ids* test-key res) + res)))) + +;; given a test-info record, patch in the latest data from the testdat.db file +;; found in the test run directory +(define (db:patch-tdb-data-into-test-info db test-id res) + (let ((tdb (db:open-test-db-by-test-id db test-id))) + ;; get state and status from megatest.db in real time + ;; other fields that perhaps should be updated: + ;; fail_count + ;; pass_count + ;; final_logf (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 ) - (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 run_id=? AND testname=? AND item_path=?;" - run-id testname item-path) - res)) + (lambda (state status final_logf) + (db:test-set-state! res state) + (db:test-set-status! res status) + (db:test-set-final_logf! res final_logf)) + db + "SELECT state,status,final_logf FROM tests WHERE id=?;" + test-id) + (if tdb + (begin + (sqlite3:for-each-row + (lambda (update_time cpuload disk_free run_duration) + (db:test-set-cpuload! res cpuload) + (db:test-set-diskfree! res disk_free) + (db:test-set-run_duration! res run_duration)) + tdb + "SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat;") + (sqlite3:finalize! tdb)) + ;; if the test db is not found what to do? + ;; 1. set state to DELETED + ;; 2. set status to n/a + (begin + (db:test-set-state! res "NOT_STARTED") + (db:test-set-status! res "n/a"))))) ;; Get test data using test_id -(define (db:get-test-data-by-id db test-id) +(define (db:get-test-info-by-id db test-id) (if (not test-id) (begin - (debug:print 0 "INFO: db:get-test-data-by-id called with test-id=" test-id) + (debug:print 4 "INFO: db:get-test-info-by-id called with test-id=" test-id) #f) - (let ((res #f)) - (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) - (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))) - + (let ((res (hash-table-ref/default *test-info* test-id #f))) + (if res + (db:patch-tdb-data-into-test-info db test-id res) + ;; if no cached value then full read and write to cache + (begin + (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) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (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) + (if res (db:patch-tdb-data-into-test-info db test-id res)) + res))))) + +(define (db:get-test-info db run-id testname item-path) + (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path))) (define (db:test-set-comment db test-id comment) (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" @@ -851,10 +899,11 @@ ;; ==> data))) ;; ==> (sqlite3:finalize! meta-stmt) ;; sqlite is the bottleneck, clear the statements asap? ;; ==> (sqlite3:finalize! step-stmt) ;; ==> (set! *incoming-data* '()) ;; ==> (mutex-unlock! *incoming-mutex*))) + (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") @@ -911,74 +960,81 @@ ;; T E S T D A T A ;;====================================================================== (define (db:csv->test-data db test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((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)) - (value (any->number-if-possible (list-ref padded-row 2))) - (expected (any->number-if-possible (list-ref padded-row 3))) - (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number - (units (list-ref padded-row 5)) - (comment (list-ref padded-row 6)) - (status (let ((s (list-ref padded-row 7))) - (if (and (string? s)(or (string-match (regexp "^\\s*$") s) - (string-match (regexp "^n/a$") s))) - #f - s))) ;; if specified on the input then use, else calculate - (type (list-ref padded-row 8))) - ;; look up expected,tol,units from previous best fit test if they are all either #f or '' - (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) - - (if (and (or (not expected)(equal? expected "")) - (or (not tol) (equal? expected "")) - (or (not units) (equal? expected ""))) - (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable))) - (set! expected new-expected) - (set! tol new-tol) - (set! units new-units))) - - (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - ;; calculate status if NOT specified - (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers - (if (number? tol) ;; if tol is a number then we do the standard comparison - (let* ((max-val (+ expected tol)) - (min-val (- expected tol)) - (result (and (>= value min-val)(<= value max-val)))) - (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) - (set! status (if result "pass" "fail"))) - (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. - (case (string->symbol tol) ;; tol should be >, <, >=, <= - ((>) (if (> value expected) "pass" "fail")) - ((<) (if (< value expected) "pass" "fail")) - ((>=) (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) - (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))) + (let ((tdb (db:open-test-db-by-test-id db test-id))) + (if tdb + (let ((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)) + (value (any->number-if-possible (list-ref padded-row 2))) + (expected (any->number-if-possible (list-ref padded-row 3))) + (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number + (units (list-ref padded-row 5)) + (comment (list-ref padded-row 6)) + (status (let ((s (list-ref padded-row 7))) + (if (and (string? s)(or (string-match (regexp "^\\s*$") s) + (string-match (regexp "^n/a$") s))) + #f + s))) ;; if specified on the input then use, else calculate + (type (list-ref padded-row 8))) + ;; look up expected,tol,units from previous best fit test if they are all either #f or '' + (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) + + (if (and (or (not expected)(equal? expected "")) + (or (not tol) (equal? expected "")) + (or (not units) (equal? expected ""))) + (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable))) + (set! expected new-expected) + (set! tol new-tol) + (set! units new-units))) + + (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + ;; calculate status if NOT specified + (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers + (if (number? tol) ;; if tol is a number then we do the standard comparison + (let* ((max-val (+ expected tol)) + (min-val (- expected tol)) + (result (and (>= value min-val)(<= value max-val)))) + (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) + (set! status (if result "pass" "fail"))) + (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. + (case (string->symbol tol) ;; tol should be >, <, >=, <= + ((>) (if (> value expected) "pass" "fail")) + ((<) (if (< value expected) "pass" "fail")) + ((>=) (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) + (sqlite3:execute tdb "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) + (sqlite3:finalize! tdb))) + csvlist))))) ;; get a list of test_data records matching categorypatt (define (db:read-test-data db test-id categorypatt) - (let ((res '())) - (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))) + (let ((tdb (db:open-test-db-by-test-id db test-id))) + (if tdb + (let ((res '())) + (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) + (sqlite3:finalize! tdb) + (reverse res)) + '()))) (define (db:load-test-data db test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin @@ -993,30 +1049,42 @@ ;; 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) - (sqlite3:execute - db - "UPDATE tests - SET fail_count=(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail'), - pass_count=(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') - WHERE id=?;" - test-id test-id test-id) - ;; if the test is not FAIL then set status based on the fail and pass counts. - (thread-sleep! 1) - (sqlite3:execute - db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME - "UPDATE tests - SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 + (let ((tdb (db:open-test-db-by-test-id db test-id)) + (fail-count 0) + (pass-count 0)) + (if tdb + (begin + (sqlite3:for-each-row + (lambda (fcount pcount) + (set! fail-count fcount) + (set! pass-count pcount)) + tdb + "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) + (sqlite3:finalize! tdb) + + ;; Now rollup the counts to the central megatest.db + (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" fail-count pass-count test-id) + + (thread-sleep! 0.1) ;; play nice with other tests + + ;; if the test is not FAIL then set status based on the fail and pass counts. + (sqlite3:execute + db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME + "UPDATE tests + SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') - THEN 'PASS' + THEN 'PASS' ELSE status END WHERE id=?;" - test-id test-id test-id test-id)) + test-id test-id test-id test-id))))) (define (db:get-prev-tol-for-test db test-id category variable) ;; Finish me? (values #f #f #f)) @@ -1167,10 +1235,11 @@ (begin (sqlite3:execute tdb "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 "")) + (sqlite3:finalize! tdb) #t) #f))) ;;====================================================================== ;; Extract ods file from the db @@ -1380,17 +1449,17 @@ (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:get-tests-for-run host port) run-id testpatt itempatt states statuses not-in: not-in)) (db:get-tests-for-run db run-id testpatt itempatt states statuses not-in: not-in))) -(define (rdb:get-test-data-by-id db test-id) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rpc:get-test-data-by-id host port) - test-id)) - (db:get-test-data-by-id db test-id))) +;; (define (rdb:get-test-data-by-id db test-id) +;; (if *runremote* +;; (let ((host (vector-ref *runremote* 0)) +;; (port (vector-ref *runremote* 1))) +;; ((rpc:procedure 'rpc:get-test-data-by-id host port) +;; test-id)) +;; (db:get-test-data-by-id db test-id))) (define (rdb:get-keys db) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) @@ -1434,16 +1503,16 @@ (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:testmeta-get-record host port) testname)) (db:testmeta-get-record db testname))) -(define (rdb:get-test-data-by-id db test-id) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:get-test-data-by-id host port) test-id)) - (db:get-test-data-by-id db test-id))) +;; (define (rdb:get-test-data-by-id db test-id) +;; (if *runremote* +;; (let ((host (vector-ref *runremote* 0)) +;; (port (vector-ref *runremote* 1))) +;; ((rpc:procedure 'rdb:get-test-data-by-id host port) test-id)) +;; (db:get-test-data-by-id db test-id))) (define (rdb:get-run-info db run-id) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -14,20 +14,21 @@ (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) -;; (define-inline (db:test-get-value vec) (printable (vector-ref vec 15))) -;; (define-inline (db:test-get-expected_value vec)(printable (vector-ref vec 16))) -;; (define-inline (db:test-get-tol vec) (printable (vector-ref vec 17))) -;; (define-inline (db:test-get-units vec) (printable (vector-ref vec 15))) ;; 18))) -(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) ;; 19))) -(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; 20))) + +(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) +(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) +(define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) +(define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) (define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) (define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) +(define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) +(define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) ;; get rows and header from (define-inline (db:get-header vec)(vector-ref vec 0)) (define-inline (db:get-rows vec)(vector-ref vec 1)) @@ -66,10 +67,22 @@ (define-inline (db:test-data-get-tol vec) (vector-ref vec 6)) (define-inline (db:test-data-get-units vec) (vector-ref vec 7)) (define-inline (db:test-data-get-comment vec) (vector-ref vec 8)) (define-inline (db:test-data-get-status vec) (vector-ref vec 9)) (define-inline (db:test-data-get-type vec) (vector-ref vec 10)) + +(define-inline (db:test-data-set-id! vec val)(vector-set! vec 0 val)) +(define-inline (db:test-data-set-test_id! vec val)(vector-set! vec 1 val)) +(define-inline (db:test-data-set-category! vec val)(vector-set! vec 2 val)) +(define-inline (db:test-data-set-variable! vec val)(vector-set! vec 3 val)) +(define-inline (db:test-data-set-value! vec val)(vector-set! vec 4 val)) +(define-inline (db:test-data-set-expected! vec val)(vector-set! vec 5 val)) +(define-inline (db:test-data-set-tol! vec val)(vector-set! vec 6 val)) +(define-inline (db:test-data-set-units! vec val)(vector-set! vec 7 val)) +(define-inline (db:test-data-set-comment! vec val)(vector-set! vec 8 val)) +(define-inline (db:test-data-set-status! vec val)(vector-set! vec 9 val)) +(define-inline (db:test-data-set-type! vec val)(vector-set! vec 10 val)) ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Run steps Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -266,11 +266,11 @@ (begin ;; (if (not (args:get-arg "-server")) ;; (server:client-setup db)) ;; (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) ;; (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) - (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) + (set! kill-job? (test-get-kill-request db test-id)) ;; run-id test-name itemdat)) (test-set-meta-info db test-id run-id test-name itemdat minutes: minutes) ;; (rdb:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) (if kill-job? (begin (mutex-lock! m) @@ -312,11 +312,11 @@ (mutex-lock! m) ;; (set! db (open-db)) ;; (if (not (args:get-arg "-server")) ;; (server:client-setup db)) (let* ((item-path (item-list->path itemdat)) - (testinfo (rdb:get-test-info db run-id test-name item-path))) + (testinfo (db:get-test-info-by-id db test-id))) ;; )) ;; run-id test-name item-path))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) (test-set-status! db test-id (if kill-job? "KILLED" "COMPLETED") @@ -408,11 +408,11 @@ ;; ;; All log file links should be stored relative to the top of link path ;; ;; - [ - ] ;; -(define (create-work-area db run-id test-src-path disk-path testname itemdat) +(define (create-work-area db run-id test-id test-src-path disk-path testname itemdat) (let* ((run-info (db:get-run-info db run-id)) (item-path (item-list->path itemdat)) (runname (db:get-value-by-header (db:get-row run-info) (db:get-header run-info) "runname")) @@ -456,11 +456,11 @@ ;; again. ;; NB - This is not working right - some top tests are not getting the path set!!! (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (db:get-test-info db run-id testname item-path)) + (let* ((testinfo (db:get-test-info-by-id db test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) (db:test-set-rundir! db run-id testname "" lnkpath) ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) @@ -556,12 +556,12 @@ (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (item-path (item-list->path itemdat)) - (testinfo (rdb:get-test-info db run-id test-name item-path)) - (test-id (db:test-get-id testinfo)) + (test-id (db:get-test-id db run-id test-name item-path)) + (testinfo (db:get-test-info-by-id db test-id)) (mt_target (string-intersperse (map cadr keyvallst) "/")) (debug-param (if (args:get-arg "-debug")(list "-debug" (args:get-arg "-debug")) '()))) (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) @@ -568,11 +568,11 @@ (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (set! diskpath (get-best-disk *configdat*)) (if diskpath - (let ((dat (create-work-area db run-id test-path diskpath test-name itemdat))) + (let ((dat (create-work-area db run-id test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) (debug:print 2 "INFO: Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -513,19 +513,20 @@ (runs:update-test_meta db test-name test-conf))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique - (testdat (db:get-test-info db run-id test-name item-path)) - (test-id #f)) + (test-id (db:get-test-id db run-id test-name item-path)) + (testdat (db:get-test-info-by-id db test-id))) (if (not testdat) (begin ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) - (rtests:register-test db run-id test-name item-path) - (set! testdat (db:get-test-info db run-id test-name item-path)))) + (tests:register-test db run-id test-name item-path) + (set! test-id (db:get-test-id db run-id test-name item-path)) + (set! testdat (db:get-test-info-by-id db test-id)))) (set! test-id (db:test-get-id testdat)) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -28,20 +28,22 @@ (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") (define (tests:register-test db run-id test-name item-path) - (let ((item-paths (if (equal? item-path "") - (list item-path) - (list item-path "")))) - (for-each - (lambda (pth) - (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" - run-id - test-name - pth)) - item-paths ))) +;; (with-dot-lock ;; NOTE: This locking only reduces the number of overlapping db accesses on a single machine!! +;; "megatest.lock" + (let ((item-paths (if (equal? item-path "") + (list item-path) + (list item-path "")))) + (for-each + (lambda (pth) + (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" + run-id + test-name + pth)) + item-paths ))) ;; ) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found (define (test:get-previous-test-run-record db run-id test-name item-path) (let* ((keys (db:get-keys db)) @@ -104,11 +106,11 @@ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (rdb:get-tests-for-run db hed test-name item-path '() '()))) + (let ((results (db:get-tests-for-run db hed test-name item-path '() '()))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) @@ -126,11 +128,11 @@ ;; (define (test-set-status! db test-id state status comment dat) (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) - (testdat (db:get-test-data-by-id db test-id)) + (testdat (db:get-test-info-by-id db test-id)) (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL @@ -364,11 +366,12 @@ (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) - (tdat (db:get-test-info db run-id test-name item-path))) + (test-id (db:get-test-id db run-id test-name item-path)) + (tdat (db:get-test-info-by-id db test-id))) (if tdat (begin ;; Look at the test state and status (if (or (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK")) @@ -379,11 +382,12 @@ ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test - (let ((wtdat (db:get-test-info db run-id waiton ""))) + (let* ((parent-test-id (db:get-test-id db run-id waiton "")) + (wtdat (db:get-test-info-by-id db test-id))) (if (or (member (db:test-get-status wtdat) '("FAIL" "KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) (set! keep-test #f)))) ;; no point in running this one again @@ -396,13 +400,13 @@ ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here -(define (test-get-kill-request 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))) +(define (test-get-kill-request db test-id) ;; run-id test-name itemdat) + (let* (;; (item-path (item-list->path itemdat)) + (testdat (db:get-test-info-by-id db test-id))) ;; run-id test-name item-path))) (equal? (test:get-state testdat) "KILLREQ"))) (define (test:tdb-get-rundat-count tdb) (if tdb (let ((res 0)) @@ -429,14 +433,14 @@ testname item-path) (if (eq? num-records 0) (begin (sqlite3:execute db "UPDATE tests SET uname=?,host=? WHERE run_id=? AND testname=? AND item_path=?;" - (get-uname "-srvpio") (get-host-name) run-id testname item-path) + (get-uname "-srvpio") (get-host-name) run-id testname item-path) (if minutes - (sqlite3:execute db "UPDATE tests SET minutes=? WHERE run_id=? AND testname=? AND item_path=?;" - minutes run-id testname item-path)))))) + (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" ;; run_id=? AND testname=? AND item_path=?;" + minutes test-id)))))) ;; run-id testname item-path)))))) (sqlite3:execute tdb "INSERT INTO test_rundat (cpuload,diskfree) VALUES (?,?);" cpuload diskfree))) ;;====================================================================== Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -102,21 +102,32 @@ ;; force keepgoing ; (hash-table-set! args:arg-hash "-keepgoing" #t) (hash-table-set! args:arg-hash "-itempatt" "%") (hash-table-set! args:arg-hash "-testpatt" "%") +(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") (test "Setup for a run" #t (begin (setup-for-run) #t)) +(define *tdb* #f) + +(define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing")) +(system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath)) + +(print "Using " testdbpath " for test db") +(test #f #t (let ((db (open-test-db testdbpath))) + (set! *tdb* db) + (sqlite3#database? db))) +(sqlite3#finalize! *tdb*) ;; (test "Remove the rollup run" #t (begin (remove-runs) #t)) (test "Run a test" #t (general-run-call "-runtests" - "run a test" - (lambda (db keys keynames keyvallst) - (let ((test-names '("runfirst"))) - (run-tests db test-names))))) + "run a test" + (lambda (db target runname keys keynames keyvallst) + (let ((test-patts "runfirst")) + (runs:run-tests db target runname test-patts user (make-hash-table)))))) (change-directory test-work-dir) (test "Add a step" #t (begin (teststep-set-status! db 1 "runfirst" "firststep" "start" 0 '() "This is a comment")