Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -54,18 +54,26 @@ ((get-runs) (apply db:get-runs db params)) ((get-runs-by-patt) (apply db:get-runs-by-patt db params)) ((lock/unlock-run) (apply db:lock/unlock-run db params)) ((update-run-event_time) (apply db:update-run-event_time db params)) + ;; STEPS + ((teststep-set-status!) (apply db:teststep-set-status! db params)) + + ;; TEST DATA + ((test-data-rollup) (apply db:test-data-rollup db params)) + ((csv->test-data) (apply db:csv->test-data db params)) + ((get-steps-data) (apply db:get-steps-data db params)) + ;; MISC ((login) (apply db:login db params)) ((general-call) (let ((stmtname (car params)) (realparams (cdr params))) (db:general-call db stmtname realparams))) ((sync-inmem->db) (db:sync-back)) ((kill-server) - (db:sync-to *inmemdb* *db*) + (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*) ;; (db:sync-to *inmemdb* *db*) (let ((hostname (car *runremote*)) (port (cadr *runremote*)) (pid (if (null? params) #f (car params))) (th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread"))) (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -411,39 +411,36 @@ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) -(define (dashboard-tests:get-compressed-steps test-id #!key (work-area #f)) - (if (or (not work-area) - (file-exists? (conc work-area "/testdat.db"))) - (let* ((steps-data (tdb:get-steps-for-test test-id work-area)) - (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) - (map (lambda (x) - ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5))) ;; time delta - (sort (hash-table-values comprsteps) - (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) - (if (and (number? time-a)(number? time-b)) - (if (< time-a time-b) - #t - (if (eq? time-a time-b) - (stringstring + (vector + (vector-ref x 0) + (let ((s (vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (vector-ref x 3) ;; status + (vector-ref x 4) + (vector-ref x 5))) ;; time delta + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (string stmt - (all-stmts '())) ;; ( ( stmt1 value1 ) ( stml2 value2 )) + (let ((stmts (make-hash-table)) ;; table-field => stmt + (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) + (numrecs (make-hash-table)) + (start-time (current-milliseconds))) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) (num-fields (length fields)) @@ -164,140 +212,152 @@ todb (lambda () (for-each ;; (lambda (fromrow) (let* ((a (vector-ref fromrow 0)) - (curr (hash-table-ref todat a)) + (curr (hash-table-ref/default todat a #f)) (same #t)) (let loop ((i 0)) - (if (not (equal? (vector-ref fromrow i)(vector-ref curr i))) + (if (or (not curr) + (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) (set! same #f)) (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) - (if (not same)(apply sqlite3:execute full-ins (vector->list fromrow))))) + (if (not same) + (begin + (apply sqlite3:execute stmth (vector->list fromrow)) + (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) fromdat))) (sqlite3:finalize! stmth)))) - tbls))) - - -(define (db:sync-to fromdb todb) - ;; strategy - ;; 1. Get all run-ids - ;; 2. For each run-id - ;; a. Sync that run in a transaction - (let ((trecchgd 0) - (rrecchgd 0) - (tmrecchgd 0)) - - ;; First sync test_meta data - (let ((tmgetstmt (sqlite3:prepare todb "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE id=?;")) - (tmputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO test_meta (id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup) - VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);")) - (tmdats (db:testmeta-get-all fromdb))) - ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) - (for-each - (lambda (tmdat) ;; iterate over tests - (let ((testm-id (vector-ref tmdat 0))) - (sqlite3:with-transaction - todb - (lambda () - (let ((curr-tmdat #f)) - (sqlite3:for-each-row - (lambda (a . b) - (set! curr-tmdat (apply vector a b))) - tmgetstmt testm-id) - (if (not (equal? curr-tmdat tmdat)) ;; something changed - (begin - (debug:print 0 " test-id: " testm-id - "\ncurr-tdat: " curr-tmdat - "\n tdat: " tmdat) - (apply sqlite3:execute tmputstmt (vector->list tmdat)) - (set! tmrecchgd (+ tmrecchgd 1))))))))) - tmdats) - (sqlite3:finalize! tmgetstmt) - (sqlite3:finalize! tmputstmt)) - - ;; First sync tests data - (let ((run-ids (db:get-all-run-ids fromdb)) - (tgetstmt (sqlite3:prepare todb "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=?;")) - (tputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO tests (id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) - VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );"))) - (for-each - (lambda (run-id) - (let ((tdats (db:get-all-tests-info-by-run-id fromdb run-id))) - ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) - (for-each - (lambda (tdat) ;; iterate over tests - (let ((test-id (vector-ref tdat 0))) - (sqlite3:with-transaction - todb - (lambda () - (let ((curr-tdat #f)) - (sqlite3:for-each-row - (lambda (a . b) - (set! curr-tdat (apply vector a b))) - tgetstmt - test-id) - (if (not (equal? curr-tdat tdat)) ;; something changed - (begin - (debug:print 0 " test-id: " test-id - "\ncurr-tdat: " curr-tdat - "\n tdat: " tdat) - (apply sqlite3:execute tputstmt (vector->list tdat)) - (set! trecchgd (+ trecchgd 1))))))))) - tdats))) - run-ids) - (sqlite3:finalize! tgetstmt) - (sqlite3:finalize! tputstmt)) - - ;; Next sync runs table - (let* ((rdats '()) - (keys (db:get-keys fromdb)) - (rstdfields (conc "id," (string-intersperse keys ",") ",runname,state,status,owner,event_time,comment,fail_count,pass_count")) - (rnumfields (length (string-split rstdfields ","))) - (runslots (string-intersperse (make-list rnumfields "?") ",")) - (rgetstmt (sqlite3:prepare todb (conc "SELECT " rstdfields " FROM runs WHERE id=?;"))) - (rputstmt (sqlite3:prepare todb (conc "INSERT OR REPLACE INTO runs (" rstdfields ") VALUES ( " runslots " );")))) - ;; first collect all the source run data - (sqlite3:for-each-row - (lambda (a . b) - (set! rdats (cons (apply vector a b) rdats))) - fromdb - (conc "SELECT " rstdfields " FROM runs;")) - (sqlite3:with-transaction - todb - (lambda () - (for-each - (lambda (rdat) - (let ((run-id (vector-ref rdat 0)) - (curr-rdat #f)) - ;; first get the current value of the equivalent row from the target - ;; read, then insert/overwrite if different - (sqlite3:for-each-row - (lambda (a . b) - (set! curr-rdat (apply vector a b))) - rgetstmt - run-id) - (if (not (equal? curr-rdat rdat)) - (begin - (debug:print 0 " run-id: " run-id - "\ncurr-rdat: " curr-rdat - "\n rdat: " rdat) - (set! rrecchgd (+ rrecchgd 1)) - (apply sqlite3:execute rputstmt (vector->list rdat)))))) - rdats))) - (sqlite3:finalize! rgetstmt) - (sqlite3:finalize! rputstmt)) - - (if (> rrecchgd 0) (debug:print 0 "synced " rrecchgd " changed records in runs table")) - (if (> trecchgd 0) (debug:print 0 "synced " trecchgd " changed records in tests table")) - (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table")) - (+ rrecchgd trecchgd tmrecchgd))) + tbls) + (let ((runtime (- (current-milliseconds) start-time))) + (debug:print 0 "INFO: db sync, total run time " runtime " ms") + (for-each + (lambda (dat) + (let ((tblname (car dat)) + (count (cdr dat))) + (if (> count 0) + (debug:print 0 (format #f " ~10a ~5a" tblname count))))) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))))) + +;; (define (db:sync-to fromdb todb) +;; ;; strategy +;; ;; 1. Get all run-ids +;; ;; 2. For each run-id +;; ;; a. Sync that run in a transaction +;; (let ((trecchgd 0) +;; (rrecchgd 0) +;; (tmrecchgd 0)) +;; +;; ;; First sync test_meta data +;; (let ((tmgetstmt (sqlite3:prepare todb "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE id=?;")) +;; (tmputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO test_meta (id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup) +;; VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);")) +;; (tmdats (db:testmeta-get-all fromdb))) +;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) +;; (for-each +;; (lambda (tmdat) ;; iterate over tests +;; (let ((testm-id (vector-ref tmdat 0))) +;; (sqlite3:with-transaction +;; todb +;; (lambda () +;; (let ((curr-tmdat #f)) +;; (sqlite3:for-each-row +;; (lambda (a . b) +;; (set! curr-tmdat (apply vector a b))) +;; tmgetstmt testm-id) +;; (if (not (equal? curr-tmdat tmdat)) ;; something changed +;; (begin +;; (debug:print 0 " test-id: " testm-id +;; "\ncurr-tdat: " curr-tmdat +;; "\n tdat: " tmdat) +;; (apply sqlite3:execute tmputstmt (vector->list tmdat)) +;; (set! tmrecchgd (+ tmrecchgd 1))))))))) +;; tmdats) +;; (sqlite3:finalize! tmgetstmt) +;; (sqlite3:finalize! tmputstmt)) +;; +;; ;; First sync tests data +;; (let ((run-ids (db:get-all-run-ids fromdb)) +;; (tgetstmt (sqlite3:prepare todb "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=?;")) +;; (tputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO tests (id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) +;; VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );"))) +;; (for-each +;; (lambda (run-id) +;; (let ((tdats (db:get-all-tests-info-by-run-id fromdb run-id))) +;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) +;; (for-each +;; (lambda (tdat) ;; iterate over tests +;; (let ((test-id (vector-ref tdat 0))) +;; (sqlite3:with-transaction +;; todb +;; (lambda () +;; (let ((curr-tdat #f)) +;; (sqlite3:for-each-row +;; (lambda (a . b) +;; (set! curr-tdat (apply vector a b))) +;; tgetstmt +;; test-id) +;; (if (not (equal? curr-tdat tdat)) ;; something changed +;; (begin +;; (debug:print 0 " test-id: " test-id +;; "\ncurr-tdat: " curr-tdat +;; "\n tdat: " tdat) +;; (apply sqlite3:execute tputstmt (vector->list tdat)) +;; (set! trecchgd (+ trecchgd 1))))))))) +;; tdats))) +;; run-ids) +;; (sqlite3:finalize! tgetstmt) +;; (sqlite3:finalize! tputstmt)) +;; +;; ;; Next sync runs table +;; (let* ((rdats '()) +;; (keys (db:get-keys fromdb)) +;; (rstdfields (conc "id," (string-intersperse keys ",") ",runname,state,status,owner,event_time,comment,fail_count,pass_count")) +;; (rnumfields (length (string-split rstdfields ","))) +;; (runslots (string-intersperse (make-list rnumfields "?") ",")) +;; (rgetstmt (sqlite3:prepare todb (conc "SELECT " rstdfields " FROM runs WHERE id=?;"))) +;; (rputstmt (sqlite3:prepare todb (conc "INSERT OR REPLACE INTO runs (" rstdfields ") VALUES ( " runslots " );")))) +;; ;; first collect all the source run data +;; (sqlite3:for-each-row +;; (lambda (a . b) +;; (set! rdats (cons (apply vector a b) rdats))) +;; fromdb +;; (conc "SELECT " rstdfields " FROM runs;")) +;; (sqlite3:with-transaction +;; todb +;; (lambda () +;; (for-each +;; (lambda (rdat) +;; (let ((run-id (vector-ref rdat 0)) +;; (curr-rdat #f)) +;; ;; first get the current value of the equivalent row from the target +;; ;; read, then insert/overwrite if different +;; (sqlite3:for-each-row +;; (lambda (a . b) +;; (set! curr-rdat (apply vector a b))) +;; rgetstmt +;; run-id) +;; (if (not (equal? curr-rdat rdat)) +;; (begin +;; (debug:print 0 " run-id: " run-id +;; "\ncurr-rdat: " curr-rdat +;; "\n rdat: " rdat) +;; (set! rrecchgd (+ rrecchgd 1)) +;; (apply sqlite3:execute rputstmt (vector->list rdat)))))) +;; rdats))) +;; (sqlite3:finalize! rgetstmt) +;; (sqlite3:finalize! rputstmt)) +;; +;; (if (> rrecchgd 0) (debug:print 0 "synced " rrecchgd " changed records in runs table")) +;; (if (> trecchgd 0) (debug:print 0 "synced " trecchgd " changed records in tests table")) +;; (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table")) +;; (+ rrecchgd trecchgd tmrecchgd))) (define (db:sync-back) - (db:sync-to *inmemdb* *db*)) + (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* @@ -1248,11 +1308,12 @@ qry ) res)) (define (db:delete-test-records db test-id) - (tdb:delete-test-step-records db test-id) + (db:general-call db 'delete-test-step-records (list test-id)) + (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 db run-id) (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) @@ -1395,15 +1456,15 @@ (begin (debug:print-info 4 "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) + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count) ;; 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))) + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count))) 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=?;" + "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,pass_count,fail_count FROM tests WHERE id=?;" test-id) res))) ;; Use db:test-get* to access ;; @@ -1413,16 +1474,16 @@ (begin (debug:print-info 4 "db:get-test-info-by-ids called with test-ids=" test-ids) '()) (let ((res '())) (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) + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment) + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count) res))) db - (conc "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 in (" + (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,pass_count,fail_count FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) 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))) @@ -1438,10 +1499,123 @@ db "SELECT rundir FROM tests WHERE id=?;" test-id) ;; (hash-table-set! *test-paths* test-id res) res)) ;; )) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile) + (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 db test-id) + (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 db test-id) + (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 +;;====================================================================== + +;; WARNING: Do NOT call this for the parent test on an iterated test +;; 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) + (let ((fail-count 0) + (pass-count 0)) + (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)) + ;; 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)))) + +(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)(tdb:get-prev-tol-for-test tdb 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))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== @@ -1607,20 +1781,23 @@ ;;====================================================================== ;; 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 ;;====================================================================== (define db:queries - (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") + (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") + + ;; TESTS + '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; Test state and status '(set-test-state "UPDATE tests SET state=? WHERE id=?;") '(set-test-status "UPDATE tests SET state=? WHERE id=?;") '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; Test comment '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") - '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") + '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "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 @@ -1632,11 +1809,10 @@ '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") - '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(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 @@ -1658,10 +1834,14 @@ WHERE run_id=? AND testname=? AND item_path != '' AND status = 'SKIP') > 0 THEN 'SKIP' ELSE 'UNKNOWN' END WHERE run_id=? AND testname=? AND item_path='';") + + ;; STEPS + '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE id=?;") + '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE id=?;") ;; using status since no state field )) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail ;; db:roll-up-pass-fail-counts ;; WHY NOT!? Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -12,10 +12,12 @@ (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) (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-pass_count vec) (vector-ref vec 15)) +(define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) (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))) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -77,12 +77,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - ;; DO NOT remote - (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: test-run-dir) + (rmt:teststep-set-status! #f test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! run-mutex) @@ -95,12 +94,11 @@ (thread-sleep! 1) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: test-run-dir)) + (rmt:teststep-set-status! #f test-id stepname "end" exinfo #f logfna)) (if logpro-used (rmt:test-set-log! test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -423,13 +423,22 @@ ;; default to three days (* 3 24 60 60))))) (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port) (let loop ((count 0)) ;; Use this opportunity to sync the inmemdb to db - (if *inmemdb* (db:sync-to *inmemdb* *db*)) + (let ((start-time (current-milliseconds)) + (sync-time #f) + (rem-time #f)) + (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + (set! sync-time (- (current-milliseconds) start-time)) + (debug:print 0 "SYNC: time= " sync-time) + (set! rem-time (quotient (- 4000 sync-time) 1000)) + (if (and (< rem-time 4) + (> rem-time 0)) + (thread-sleep! rem-time))) - (thread-sleep! 4) ;; no need to do this very often + ;; (thread-sleep! 4) ;; no need to do this very often (if (< count 1) ;; 3x3 = 9 secs aprox (loop (+ count 1))) ;; Check that iface and port have not changed (can happen if server port collides) @@ -462,11 +471,11 @@ (loop 0)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) - (if *inmemdb* (db:sync-to *inmemdb* *db*)) + (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) (thread-sleep! 1) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Number of cached writes " *number-of-writes*) (debug:print-info 0 "Average cached write time " @@ -509,11 +518,11 @@ (th3 (make-thread http-transport:keep-running "Keep running"))) ;; (th1 (make-thread server:write-queue-handler "write queue"))) (set! *cache-on* #t) (set! *db* (open-db)) (set! *inmemdb* (open-in-mem-db)) - (db:sync-to *db* *inmemdb*) + (db:sync-tables (db:tbls *db*) *db* *inmemdb*) ;; (db:sync-to *db* *inmemdb*) (thread-start! th2) (thread-start! th3) ;; (thread-start! th1) (set! *didsomething* #t) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -235,12 +235,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - ;; DO NOT remote - (tdb:teststep-set-status! test-id stepname "start" "-" #f #f work-area: work-area) + (rmt:teststep-set-status! test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) @@ -253,12 +252,11 @@ (thread-sleep! 2) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (tdb:teststep-set-status! test-id stepname "end" exinfo #f logfna work-area: work-area)) + (rmt:teststep-set-status! test-id stepname "end" exinfo #f logfna)) (if logpro-used (rmt:test-set-log! test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -632,11 +632,11 @@ "\n uname: " (db:test-get-uname test) "\n rundir: " (db:test-get-rundir test) ) ;; Each test ;; DO NOT remote run - (let ((steps (tdb:get-steps-for-test (db:test-get-id test)))) + (let ((steps (db:get-steps-for-test db (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (tdb:step-get-stepname step) @@ -902,12 +902,11 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) - ;; DO NOT remote run, makes calls to the testdat.db test db. - (tdb:teststep-set-status! test-id step state status msg logfile work-area: work-area) + (rmt:teststep-set-status! test-id step state status msg logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") @@ -962,11 +961,11 @@ ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close - (tdb:load-test-data test-id work-area: work-area)) + (tdb:load-test-data test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) (rmt:test-set-log! test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote @@ -993,16 +992,15 @@ (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - ;; DO NOT run remote - (tdb:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area) + (rmt:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) - (set! exitstat (system fullcmd)) ;; cmd params)) + (set! exitstat (system fullcmd)) (set! *globalexitstatus* exitstat) ;; (change-directory testpath) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) @@ -1013,12 +1011,11 @@ (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (rmt:test-set-log! test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - ;; DO NOT run remote - (tdb:teststep-set-status! test-id stepname "end" exitstat msg logfile work-area: work-area)) + (rmt:teststep-set-status! test-id stepname "end" exitstat msg logfile)) ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -221,15 +221,23 @@ ;; 2. Open the testdat.db file and do the query ;; If not given the work area ;; 1. Do a remote call to get the test path ;; 2. Continue as above ;; -(define (rmt:get-steps-for-test test-id #!key (work-area #f)) - (let* ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area))) - (if tdb - (tdb:get-steps-data tdb test-id) - '()))) +(define (rmt:get-steps-for-test test-id) + (rmt:send-receive 'get-steps-data (list test-id))) + +(define (rmt:teststep-set-status! test-id teststep-name state-in status-in comment logfile) + (let* ((state (items:check-valid-items "state" state-in)) + (status (items:check-valid-items "status" status-in))) + (if (or (not state)(not status)) + (debug:print 3 "WARNING: Invalid " (if status "status" "state") + " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) + (rmt:send-receive 'teststep-set-status! (list test-id teststep-name state-in status-in comment logfile)))) + +(define (rmt:get-steps-for-test test-id) + (rmt:send-receive 'get-steps-for-test (list test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== @@ -245,5 +253,11 @@ (define (rmt:testmeta-get-record testname) (rmt:send-receive 'testmeta-get-record (list testname))) (define (rmt:testmeta-update-field test-name fld val) (rmt:send-receive 'testmeta-update-field (list test-name fld val))) + +(define (rmt:test-data-rollup test-id status) + (rmt:send-receive 'test-data-rollup (list test-id status))) + +(define (rmt:csv->test-data test-id csvdata) + (rmt:send-receive 'csv->test-data (list test-id csvdata))) Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -158,21 +158,10 @@ val TEXT, ackstate INTEGER DEFAULT 0, CONSTRAINT metadat_constraint UNIQUE (var));")) (debug:print 11 "db:testdb-initialize END")) -(define (tdb:get-steps-data tdb test-id) - (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))) - tdb - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (sqlite3:finalize! tdb) - (reverse res))) - (define (tdb:read-test-data tdb 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))) @@ -183,70 +172,10 @@ ;;====================================================================== ;; T E S T D A T A ;;====================================================================== -(define (tdb:csv->test-data test-id csvdata #!key (work-area #f)) - (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((tdb (tdb:open-test-db-by-test-id-local test-id work-area: work-area))) - (if (sqlite3:database? 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)(tdb:get-prev-tol-for-test tdb 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))) - csvlist) - (sqlite3:finalize! tdb))))) - ;; ;; get a list of test_data records matching categorypatt ;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f)) ;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area))) ;; (if (sqlite3:database? tdb) ;; (let ((res '())) @@ -258,67 +187,20 @@ ;; (sqlite3:finalize! tdb) ;; (reverse res)) ;; '()))) ;; NOTE: Run this local with #f for db !!! -(define (tdb:load-test-data test-id #!key (work-area #f)) +(define (tdb:load-test-data test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) - (tdb:csv->test-data test-id lin work-area: work-area) + (rmt:csv->test-data test-id lin) (loop (read-line))))) ;; roll up the current results. - ;; FIXME: Add the status to - (tdb:test-data-rollup test-id #f work-area: work-area)) - -;; WARNING: Do NOT call this for the parent test on an iterated test -;; 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 (tdb:test-data-rollup test-id status #!key (work-area #f)) - (let ((tdb (tdb:open-test-db-by-test-id-local test-id work-area: work-area)) - (fail-count 0) - (pass-count 0)) - (if (sqlite3:database? 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) - - ;; Now rollup the counts to the central megatest.db - (rmt:general-call 'pass-fail-counts fail-count pass-count test-id) - ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" - ;; fail-count pass-count test-id) - - ;; The flush is not needed with the transaction based write agregation enabled. Remove these commented lines - ;; next time you read this! - ;; - ;; (cdb:flush-queue *runremote*) - ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set - - ;; if the test is not FAIL then set status based on the fail and pass counts. - (rmt:general-call 'test_data-pf-rollup test-id test-id test-id test-id) - ;; (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' - ;; ELSE status - ;; END WHERE id=?;" - ;; test-id test-id test-id test-id) - (sqlite3:finalize! tdb) - )))) + ;; FIXME: Add the status too + (rmt:test-data-rollup test-id #f)) (define (tdb:get-prev-tol-for-test tdb test-id category variable) ;; Finish me? (values #f #f #f)) @@ -327,207 +209,156 @@ ;;====================================================================== (define (tdb:step-get-time-as-string vec) (seconds->time-string (tdb:step-get-event_time vec))) -;; db-get-test-steps-for-run -(define (tdb:get-steps-for-test test-id #!key (work-area #f)) - (let* ((tdb (tdb:open-test-db-by-test-id-local test-id work-area: work-area)) - (res '())) - (if (sqlite3:database? tdb) - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: error on access to testdat for test with id " test-id) - '()) - (begin - (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))) - tdb - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (sqlite3:finalize! tdb) - (reverse res))) - '()))) - -;; get a pretty table to summarize steps -;; -(define (tdb:get-steps-table test-id #!key (work-area #f)) - (let ((steps (tdb:get-steps-for-test test-id work-area: work-area))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (lambda (step) - (debug:print 6 "step=" step) - (let ((record (hash-table-ref/default - res - (tdb:step-get-stepname step) - ;; stepname start end status Duration Logfile - (vector (tdb:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)) - (case (string->symbol (tdb:step-get-state step)) - ((start)(vector-set! record 1 (tdb:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (tdb:step-get-status step))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (tdb:step-get-event_time step))) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (tdb:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - (else - (vector-set! record 2 (tdb:step-get-state step)) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (tdb:step-get-event_time step)))) - (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)))) - ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) - ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) - (< (tdb:step-get-id a) (tdb:step-get-id b))) - (else #f))))) - res))) - -;; get a pretty table to summarize steps -;; -(define (tdb:get-steps-table-list test-id #!key (work-area #f)) - (let ((steps (tdb:get-steps-for-test test-id work-area: work-area))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (lambda (step) - (debug:print 6 "step=" step) - (let ((record (hash-table-ref/default - res - (tdb:step-get-stepname step) - ;; stepname start end status - (vector (tdb:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)) - (case (string->symbol (tdb:step-get-state step)) - ((start)(vector-set! record 1 (tdb:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (tdb:step-get-status step))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (tdb:step-get-event_time step))) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (tdb:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - (else - (vector-set! record 2 (tdb:step-get-state step)) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (tdb:step-get-event_time step)))) - (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)))) - ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) - ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) - (< (tdb:step-get-id a) (tdb:step-get-id b))) - (else #f))))) - res))) - -(define (tdb:get-compressed-steps test-id #!key (work-area #f)(tdb #f)) - (if (or (not work-area) - (file-exists? (conc work-area "/testdat.db"))) - (let* ((comprsteps (tdb:get-steps-table test-id work-area: work-area))) - (map (lambda (x) - ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5))) ;; time delta - (sort (hash-table-values comprsteps) - (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) - (if (and (number? time-a)(number? time-b)) - (if (< time-a time-b) - #t - (if (eq? time-a time-b) - (stringsymbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (tdb:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + (else + (vector-set! record 2 (tdb:step-get-state step)) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (tdb:step-get-event_time step)))) + (hash-table-set! res (tdb:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) + (< (tdb:step-get-id a) (tdb:step-get-id b))) + (else #f))))) + res)) + +;; Move this to steps.scm +;; +;; get a pretty table to summarize steps +;; +(define (tdb:get-steps-table-list steps) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 "step=" step) + (let ((record (hash-table-ref/default + res + (tdb:step-get-stepname step) + ;; stepname start end status + (vector (tdb:step-get-stepname step) "" "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)) + (case (string->symbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (tdb:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + (else + (vector-set! record 2 (tdb:step-get-state step)) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (tdb:step-get-event_time step)))) + (hash-table-set! res (tdb:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) + (< (tdb:step-get-id a) (tdb:step-get-id b))) + (else #f))))) + res)) + +;; +;; Move to steps.scm +;; +(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table + (map (lambda (x) + ;; take advantage of the \n on time->string + (vector + (vector-ref x 0) + (let ((s (vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (vector-ref x 3) ;; status + (vector-ref x 4) + (vector-ref x 5))) ;; time delta + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (string