Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -28,10 +28,11 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;; global gletches +(define *db-keys* #f) (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) @@ -40,12 +41,18 @@ (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold (define *last-db-access* 0) ;; update when db is accessed via server -(define *target* #f) ;; cache the target here; target is keyval1/keyval2/.../keyvalN +(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 @@ -197,21 +197,21 @@ (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (rdb:test-set-state-status-by-id *db* test-id #f #f b) + (open-run-close db:test-set-state-status-by-id *db* test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL")) (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (rdb:test-set-state-status-by-id *db* test-id state #f #f) + (open-run-close db:test-set-state-status-by-id *db* test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -227,11 +227,11 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (rdb:test-set-state-status-by-id *db* test-id #f status #f) + (open-run-close db:test-set-state-status-by-id *db* test-id #f status #f) (db:test-set-status! testdat status))))) btn)) (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED")))) (vector-set! *state-status* 1 (lambda (status color) @@ -246,33 +246,34 @@ ;;====================================================================== ;; ;;====================================================================== -(define (examine-test db test-id) ;; run-id run-key origtest) - (let* ((testdat (rdb:get-test-data-by-id db test-id)) +(define (examine-test test-id) ;; run-id run-key origtest) + (let* ((testdat (open-run-close db:get-test-info-by-id #f test-id)) (db-path (conc *toppath* "/megatest.db")) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) - (request-update #t)) + (request-update #t) + (db #f)) (if (not testdat) (begin (debug:print 0 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* ((run-id (if testdat (db:test-get-run_id testdat) #f)) - (keydat (if testdat (rdb:get-key-val-pairs db run-id) #f)) - (rundat (if testdat (rdb:get-run-info db run-id) #f)) + (keydat (if testdat (open-run-close db:get-key-val-pairs db run-id) #f)) + (rundat (if testdat (open-run-close db:get-run-info db run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "runname") #f)) ;(teststeps (if testdat (db:get-steps-for-test db test-id) #f)) (logfile "/this/dir/better/not/exist") (rundir logfile) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat - (let ((tm (db:testmeta-get-record db testname))) + (let ((tm (open-run-close db:testmeta-get-record db testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -297,15 +298,15 @@ (refreshdat (lambda () (let* ((curr-mod-time (file-modification-time db-path)) (need-update (or (and (> curr-mod-time db-mod-time) (> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched request-update)) - (newtestdat (if need-update (rdb:get-test-data-by-id db test-id)))) + (newtestdat (if need-update (open-run-close db:get-test-info-by-id db test-id)))) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (rdb:get-steps-for-test db test-id)) + (set! teststeps (open-run-close db:get-steps-for-test db test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat))) (need-update ;; if this was true and yet there is no data .... (db:test-set-testname! testdat "DEAD OR DELETED TEST")))))) @@ -400,11 +401,11 @@ #:size "60x100"))) (hash-table-set! widgets "Test Steps" (lambda (testdat) (let* ((currval (iup:attribute stepsdat "VALUE")) ;; "TITLE")) (fmtstr "~20a~10a~10a~12a~15a~20a") - (comprsteps (rdb:get-steps-table db test-id)) + (comprsteps (open-run-close db:get-steps-table db test-id)) (newval (string-intersperse (append (list (format #f fmtstr "Stepname" "Start" "End" "Status" "Time" "Logfile") (format #f fmtstr "========" "=====" "===" "======" "====" "=======")) @@ -458,11 +459,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (db:read-test-data db test-id "%"))) + (open-run-close db:read-test-data db test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data))) ))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -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. ;; @@ -75,30 +75,30 @@ (if (not (setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *db* (open-db)) +(define *db* #f) ;; (open-db)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (server:client-setup *db*) (define toplevel #f) (define dlg #f) (define max-test-num 0) -(define *keys* (rdb:get-keys *db*)) +(define *keys* (open-run-close db:get-keys *db*)) ;; (define *keys* (db:get-keys *db*)) (define *dbkeys* (map (lambda (x)(vector-ref x 0)) (append *keys* (list (vector "runname" "blah"))))) (define *header* #f) (define *allruns* '()) (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) -(define *tot-run-count* (rdb:get-num-runs *db* "%")) +(define *tot-run-count* (open-run-close db:get-num-runs *db* "%")) ;; (define *tot-run-count* (db:get-num-runs *db* "%")) (define *last-update* (current-seconds)) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) @@ -166,11 +166,11 @@ (begin (debug:print 4 "INFO: update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " itemnamepatt: " itemnamepatt " keypatts: " keypatts) (set! *please-update-buttons* #t) (set! *last-db-update-time* modtime) (set! *delayed-update* (- *delayed-update* 1)) - (let* ((allruns (rdb:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (let* ((allruns (open-run-close db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) @@ -181,13 +181,13 @@ (begin (set! *last-update* (current-seconds)) (set! *tot-run-count* (length runs)))) ;; (rdb:get-num-runs *db* runnamepatt)))) (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (let ((tsts (rdb:get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses))) + (tests (let ((tsts (open-run-close db:get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses))) (if *tests-sort-reverse* (reverse tsts) tsts))) - (key-vals (rdb:get-key-vals *db* run-id))) + (key-vals (open-run-close db:get-key-vals *db* run-id))) (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set (not (null? tests))) (set! result (cons (vector run tests key-vals) result))))) @@ -637,18 +637,18 @@ (if runid (begin (lambda (x) (on-exit (lambda () (sqlite3:finalize! *db*))) - (examine-run *db* runid))) + (open-run-close examine-run *db* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") (let ((testid (string->number (args:get-arg "-test")))) (if testid - (examine-test *db* testid) + (examine-test testid) (begin (print "ERROR: testid is not a number " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -46,15 +46,21 @@ (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")) + (begin + (debug:print 5 "INFO: Turning off pragma synchronous") + (sqlite3:execute db "PRAGMA synchronous = 0;")) + (debug:print 5 "INFO: NOT turning off pragma synchronous")) db)) + +(define (open-run-close proc idb . params) + (let* ((db (if idb idb (open-db))) + (res (apply proc db params))) + (if (not idb)(sqlite3:finalize! db)) + res)) (define (db:initialize db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (config-get-fields configdat)) (havekeys (> (length keys) 0)) @@ -155,10 +161,80 @@ CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") ;; Must do this *after* running patch db !! No more. (db:set-var db "MEGATEST_VERSION" megatest-version) )) +;; Create the sqlite db for the individual test(s) +(define (open-test-db testpath) + (if (and (directory? testpath) + (file-read-access? testpath)) + (let* ((dbpath (conc testpath "/testdat.db")) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (handler (make-busy-timeout (if (args:get-arg "-override-timeout") + (string->number (args:get-arg "-override-timeout")) + 36000)))) + (debug:print 4 "INFO: test dbpath=" dbpath) + (sqlite3:set-busy-handler! db handler) + (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;") + db) + #f)) + +;; find and open the testdat.db file for an existing test +(define (db:open-test-db-by-test-id db test-id) + (let* ((test-path (db:test-get-rundir-from-test-id db test-id))) + (open-test-db test-path))) + +(define (db:testdb-initialize db) + (for-each + (lambda (sqlcmd) + (sqlite3:execute db sqlcmd)) + (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, + 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, + expected REAL, + tol REAL, + units TEXT, + comment TEXT DEFAULT '', + status TEXT DEFAULT 'n/a', + type TEXT DEFAULT '', + CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" + "CREATE TABLE IF NOT EXISTS test_steps ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + stepname TEXT, + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'n/a', + event_time TIMESTAMP, + comment TEXT DEFAULT '', + logfile TEXT DEFAULT '', + CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" + ;; test_meta can be used for handing commands to the test + ;; e.g. KILLREQ + ;; the ackstate is set to 1 once the command has been completed + "CREATE TABLE IF NOT EXISTS test_meta ( + id INTEGER PRIMARY KEY, + var TEXT, + val TEXT, + ackstate INTEGER DEFAULT 0, + CONSTRAINT metadat_constraint UNIQUE (var));"))) + ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers ;; apply all from last to current ;;====================================================================== @@ -262,12 +338,10 @@ (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) ;; use a global for some primitive caching, it is just silly to re-read the db ;; over and over again for the keys since they never change -(define *db-keys* #f) - (define (db:get-keys db) (if *db-keys* *db-keys* (let ((res '())) (sqlite3:for-each-row (lambda (key keytype) @@ -424,32 +498,38 @@ keys) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals db run-id) - (let* ((keys (get-keys db)) - (res '())) - (debug:print 6 "keys: " keys " run-id: " run-id) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons key-val res))) - db qry run-id))) - keys) - (reverse res))) + (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) + (if mykeyvals + mykeyvals + (let* ((keys (get-keys db)) + (res '())) + (debug:print 6 "keys: " keys " run-id: " run-id) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) + ;; (debug:print 0 "qry: " qry) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons key-val res))) + db qry run-id))) + keys) + (let ((final-res (reverse res))) + (hash-table-set! *keyvals* run-id final-res) + final-res))))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often (define (db:get-target db run-id) - (if *target* - *target* - (let* ((keyvals (rdb:get-key-vals db run-id)) - (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) - (set! *target* thekey) - thekey))) + (let ((mytarg (hash-table-ref/default *target* run-id #f))) + (if mytarg + mytarg + (let* ((keyvals (db:get-key-vals db run-id)) ;; (rdb:get-key-vals db run-id)) + (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) + (hash-table-set! *target* run-id thekey) + thekey)))) ;;====================================================================== ;; T E S T S ;;====================================================================== @@ -491,26 +571,20 @@ ;; (if itempatt itempatt "%")) ) res)) ;; this one is a bit broken BUG FIXME -(define (db:delete-test-step-records db run-id test-name itemdat) +(define (db:delete-test-step-records db test-id) ;; Breaking it into two queries for better file access interleaving - (let ((ids '())) - (sqlite3:for-each-row (lambda (id) - (set! ids (cons id ids))) - db - "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;" - run-id test-name (item-list->path itemdat)) - (for-each (lambda (id) - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" id) - (thread-sleep! 0.1) ;; give others access to the db - (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" id) - (thread-sleep! 0.1)) ;; give others access to the db - ids))) -;;"DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?);" - + (let* ((tdb (db:open-test-db-by-test-id db test-id))) + ;; test db's can go away - must check every time + (if tdb + (begin + (sqlite3:execute tdb "DELETE FROM test_steps;") + (sqlite3:execute tdb "DELETE FROM test_data;") + (sqlite3:finalize! tdb))))) + ;; (define (db:delete-test-records db test-id) (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)) @@ -530,13 +604,19 @@ (define (db:delete-tests-in-state db run-id state) (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id)) (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) - (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) - (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) - (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))) + (cond + ((and newstate newstatus newcomment) + (sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id)) + ((and newstate newstatus) + (sqlite3:exectute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) + (else + (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) + (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) + (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))) (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" state status run-id test-name item-path)) @@ -571,36 +651,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=?;" @@ -611,10 +738,25 @@ (sqlite3:execute db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" rundir run-id test-name item-path)) +;; +(define (db:test-get-rundir-from-test-id db test-id) + (let ((res (hash-table-ref/default *test-paths* test-id #f))) + (if res + res + (begin + (sqlite3:for-each-row + (lambda (tpath) + (set! res tpath)) + db + "SELECT rundir FROM tests WHERE id=?;" + test-id) + (hash-table-set! *test-paths* test-id res) + res)))) + (define (db:test-set-log! db test-id logf) (if (string? logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE id=?;" logf test-id) (debug:print 0 "ERROR: db:test-set-log! called with non-string log file name " logf))) @@ -725,53 +867,55 @@ ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS ;;====================================================================== -(define (db:updater db) - (let loop ((start-time (current-time))) - (thread-sleep! 0.5) ;; move save time around to minimize regular collisions? - (db:write-cached-data db) - (loop start-time))) - -(define (db:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) - (mutex-lock! *incoming-mutex*) - (set! *incoming-data* (cons (vector 'meta-info - (current-seconds) - (list cpuload - diskfree - minutes - test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) - *incoming-data*)) - (mutex-unlock! *incoming-mutex*) - (if *cache-on* - (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write as part of test-update-meta-info") - (db:write-cached-data db))) - -(define (db:write-cached-data db) - (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');")) - (step-stmt (sqlite3:prepare db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);")) ;; strftime('%s','now')#f) - (data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))) - (if (> (length data) 0) - (debug:print 4 "Writing cached data " data)) - (mutex-lock! *incoming-mutex*) - (sqlite3:with-transaction - db - (lambda () - (for-each (lambda (entry) - (case (vector-ref entry 0) - ((meta-info) - (apply sqlite3:execute meta-stmt (vector-ref entry 2))) - ((step-status) - (apply sqlite3:execute step-stmt (vector-ref entry 2))) - (else - (debug:print 0 "ERROR: Queued entry not recognised " entry)))) - 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:updater db) +;; (let loop ((start-time (current-time))) +;; (thread-sleep! 0.5) ;; move save time around to minimize regular collisions? +;; (db:write-cached-data db) +;; (loop start-time))) +;; +;; (define (db:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) +;; (mutex-lock! *incoming-mutex*) +;; (set! *incoming-data* (cons (vector 'meta-info +;; (current-seconds) +;; (list cpuload +;; diskfree +;; minutes +;; test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) +;; *incoming-data*)) +;; (mutex-unlock! *incoming-mutex*) +;; (if *cache-on* +;; (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write as part of test-update-meta-info") +;; (db:write-cached-data db))) +;; + +;; ==> (define (db:write-cached-data db) +;; ==> (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');")) +;; ==> (step-stmt (sqlite3:prepare db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);")) ;; strftime('%s','now')#f) +;; ==> (data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))) +;; ==> (if (> (length data) 0) +;; ==> (debug:print 4 "Writing cached data " data)) +;; ==> (mutex-lock! *incoming-mutex*) +;; ==> (sqlite3:with-transaction +;; ==> db +;; ==> (lambda () +;; ==> (for-each (lambda (entry) +;; ==> (case (vector-ref entry 0) +;; ==> ((meta-info) +;; ==> (apply sqlite3:execute meta-stmt (vector-ref entry 2))) +;; ==> ((step-status) +;; ==> (apply sqlite3:execute step-stmt (vector-ref entry 2))) +;; ==> (else +;; ==> (debug:print 0 "ERROR: Queued entry not recognised " entry)))) +;; ==> 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") @@ -828,74 +972,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))) + tdb + "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 @@ -910,30 +1061,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)) @@ -944,18 +1107,23 @@ (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; 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 test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (reverse res))) + (let* ((tdb (db:open-test-db-by-test-id db test-id)) + (res '())) + (if tdb + (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 (db:get-steps-table db test-id) (let ((steps (db:get-steps-for-test db test-id))) @@ -1067,24 +1235,25 @@ waitons) (delete-duplicates result)))) (define (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile) (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) - (let* ((state (check-valid-items "state" state-in)) + (let* ((tdb (db:open-test-db-by-test-id db test-id)) + (state (check-valid-items "state" state-in)) (status (check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 0 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (mutex-lock! *incoming-mutex*) - (set! *incoming-data* (cons (vector 'step-status - (current-seconds) - ;; FIXME - this should not update the logfile unless it is specified. - (list test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))) - *incoming-data*)) - (mutex-unlock! *incoming-mutex*) - (if (not *cache-on*)(db:write-cached-data db)) - #t)) + (if tdb + (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 ;;====================================================================== @@ -1292,17 +1461,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))) @@ -1346,16 +1515,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 ADDED docs/plan.txt Index: docs/plan.txt ================================================================== --- /dev/null +++ docs/plan.txt @@ -0,0 +1,13 @@ + +Move test specific db to test dir +================================= + +. Create teststats.db +. Redirect test run stats to teststats.db +. Redirect test steps data to teststats.db +. Redirect test_data to teststats.db +. Direct dboard to get stats from teststats.db +. Redirect kill requests to teststats.db +. Kill requests need to kill all processes in the tree +. Roll up overall stats to megatest.db every five minutes or when test done +. Add any necessary tests Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -63,11 +63,10 @@ (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (if runscript (conc testpath "/" runscript) #f)) - (db #f) (rollup-status 0)) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config @@ -91,41 +90,35 @@ (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) (change-directory top-path) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") + ;; (sqlite3:finalize! db) + ;; (sqlite3:finalize! tdb) (exit 1))) (change-directory *toppath*) - ;; now can find our db - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - ;; (set! *cache-on* #t) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + + (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process (change-directory work-area) - (set-run-config-vars db run-id) + + (open-run-close set-run-config-vars #f run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (set-megatest-env-vars db run-id) + (open-run-close set-megatest-env-vars #f run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") - (test-set-meta-info db run-id test-name itemdat) - (test-set-status! db test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) + (open-run-close test-set-meta-info #f test-id run-id test-name itemdat) + (open-run-close test-set-status! #f test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test ;; so this is a good place to remove the records for ;; any previous runs ;; (db:test-remove-steps db run-id testname itemdat) - ;; from here on out we will open and close the db - ;; on every access to reduce the probablitiy of - ;; contention or stuck access on nfs. - (sqlite3:finalize! db) - (let* ((m (make-mutex)) (kill-job? #f) (exit-info (vector #t #t #t)) (job-thread #f) (runit (lambda () @@ -152,14 +145,11 @@ ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? - (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) - (db (open-db))) - (if (not (args:get-arg "-server")) - (server:client-setup db)) + (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) @@ -189,11 +179,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (rdb:teststep-set-status! db test-id stepname "start" "-" itemdat #f #f) + (open-run-close db:teststep-set-status! #f test-id stepname "start" "-" itemdat #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) @@ -207,13 +197,13 @@ (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) - (rdb:teststep-set-status! db test-id stepname "end" exinfo itemdat #f logfna)) + (open-run-close db:teststep-set-status! #f test-id stepname "end" exinfo itemdat #f logfna)) (if logpro-used - (rdb:test-set-log! db test-id (conc stepname ".html"))) + (open-run-close db:test-set-log! #f 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) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) @@ -231,18 +221,18 @@ " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood - (test-set-status! db test-id "RUNNING" "WARN" + (open-run-close test-set-status! #f test-id "RUNNING" "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) - (test-set-status! db test-id "RUNNING" "PASS" #f #f)) + (open-run-close test-set-status! #f test-id "RUNNING" "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail - (test-set-status! db test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + (open-run-close test-set-status! #f test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) @@ -254,20 +244,22 @@ (- (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) - (let* ((db (open-db)) - (cpuload (get-cpu-load)) - (diskfree (get-df (current-directory))) - (tmpfree (get-df "/tmp"))) - (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)) - (rdb:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) + ;; (let* (;; (db (open-db)) + ;; (cpuload (get-cpu-load)) + ;; (diskfree (get-df (current-directory))) + ;; (tmpfree (get-df "/tmp"))) + (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? (open-run-close test-get-kill-request #f test-id)) ;; run-id test-name itemdat)) + (open-run-close test-set-meta-info #f 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) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) @@ -286,35 +278,35 @@ (system (conc "kill -9 " p-id)))))) (car processes)) (system (conc "kill -9 " pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") - (test-set-status! db test-id "KILLED" "FAIL" + (open-run-close test-set-status! #f test-id "KILLED" "FAIL" (args:get-arg "-m") #f) - (sqlite3:finalize! db) + (sqlite3:finalize! tdb) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) - (sqlite3:finalize! db) + ;; (sqlite3:finalize! db) (thread-sleep! (+ 10 (random 10))) ;; add some jitter to the call home time to spread out the db accesses (loop (calc-minutes))))))) (th1 (make-thread monitorjob)) (th2 (make-thread runit))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (mutex-lock! m) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) + ;; (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 (open-run-close db:get-test-info-by-id #f 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 + (open-run-close test-set-status! #f test-id (if kill-job? "KILLED" "COMPLETED") ;; Old logic: ;; (if (vector-ref exit-info 1) ;; look at the exit-status, #t means it at least ran ;; (if (and (not kill-job?) ;; (eq? (vector-ref exit-info 2) 0)) ;; we can now use rollup-status instead @@ -333,18 +325,19 @@ (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")) (args:get-arg "-m") #f))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) - (tests:summarize-items db run-id test-name #f)) ;; don't force - just update if no + (open-run-close tests:summarize-items #f run-id test-name #f)) ;; don't force - just update if no ) (mutex-unlock! m) ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") (sqlite3:finalize! db) + (sqlite3:finalize! tdb) (if (not (vector-ref exit-info 1)) (exit 4))))))) ;; set up the very basics needed for doing anything here. (define (setup-for-run) @@ -401,11 +394,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")) @@ -449,11 +442,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))) @@ -549,12 +542,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")) @@ -561,11 +554,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")) @@ -587,11 +580,11 @@ (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) ;; clean out step records from previous run if they exist - (db:delete-test-step-records db run-id test-name itemdat) + (db:delete-test-step-records db test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -62,11 +62,10 @@ (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) - (define (set-megatest-env-vars db run-id) (let ((keys (rdb:get-keys db))) (for-each (lambda (key) (sqlite3:for-each-row (lambda (val) @@ -204,10 +203,12 @@ ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (db:delete-tests-in-state db run-id "NOT_STARTED") (rdb:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + ;; from here on out the db will be opened and closed on every call runs:run-tests-queue + (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (let* ((config (tests:get-testconfig hed 'return-procs)) @@ -270,16 +271,15 @@ (loop (car remtests)(cdr remtests))))))) (if (not (null? required-tests)) (debug:print 1 "INFO: Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. - (runs:run-tests-queue db run-id runname test-records keyvallst flags) - (if *rpc:listener* (server:keep-running db)) + (runs:run-tests-queue run-id runname test-records keyvallst flags) (debug:print 4 "INFO: All done by here"))) ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue db run-id runname test-records keyvallst flags) +(define (runs:run-tests-queue run-id runname test-records keyvallst flags) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (item-patts (hash-table-ref/default flags "-itempatt" #f))) @@ -311,12 +311,12 @@ (or (not (vector? t)) (not (equal? "COMPLETED" (db:test-get-state t))))) prereqs-not-met))) (pretty-string (lambda (lst) (map (lambda (t) - (if (string? t) - t + (if (not (vector? t)) + (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)))) (debug:print 6 "itemdat: " itemdat "\n items: " items @@ -330,18 +330,20 @@ (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (let* ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running - (prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path mode: testmode)) + (let* ((have-resources (open-run-close runs:can-run-more-tests #f test-record)) ;; look at the test jobgroup and tot jobs running + (prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) (fails (calc-fails prereqs-not-met)) (non-completed (calc-not-completed prereqs-not-met))) (debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " (string-intersperse (map (lambda (t) - (conc (db:test-get-state t)"/"(db:test-get-status t))) + (if (not (vector? t)) + (conc " WARNING: t is not a vector=" t ) + (conc (db:test-get-state t) "/" (db:test-get-status t)))) prereqs-not-met) ", ") " fails: " fails) ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? (cond ((and have-resources @@ -348,11 +350,11 @@ (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) ;; no loop here, just drop though and use the loop at the bottom (if (patt-list-match item-path item-patts) - (run:test db run-id runname keyvallst test-record flags #f) + (run:test run-id runname keyvallst test-record flags #f) (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts)) ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites ) ((not have-resources) ;; simply try again after waiting a second @@ -407,13 +409,13 @@ (loop (car tal)(cdr tal)))) ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests db test-record))) + (let ((can-run-more (open-run-close runs:can-run-more-tests #f test-record))) (if can-run-more - (let* ((prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path mode: testmode)) + (let* ((prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) (fails (calc-fails prereqs-not-met)) (non-completed (calc-not-completed prereqs-not-met))) (debug:print 8 "INFO: can-run-more: " can-run-more "\n prereqs-not-met: " (pretty-string prereqs-not-met) "\n non-completed: " (pretty-string non-completed) @@ -427,11 +429,11 @@ (and (eq? testmode 'toplevel) (null? non-completed))) (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (tests:testqueue-set-items! test-record items-list) (loop hed tal)) @@ -471,27 +473,28 @@ ;; FIXME! This harsh exit should not be necessary.... (if (not *runremote*)(exit)) ;; #f) ;; return a #f as a hint that we are done ;; Here we need to check that all the tests remaining to be run are eligible to run ;; and are not blocked by failed - (let ((newlst (tests:filter-non-runnable db run-id tal test-records))) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, + (let ((newlst (open-run-close tests:filter-non-runnable #f run-id tal test-records))) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, (thread-sleep! 0.1) (if (not (null? newlst)) (loop (car newlst)(cdr newlst))))))))) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step -(define (run:test db run-id runname keyvallst test-record flags parent-test) +(define (run:test run-id runname keyvallst test-record flags parent-test) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (test-path (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) - (item-path "")) + (item-path "") + (db #f)) (debug:print 5 "test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) ;; setting itemdat to a list if it is #f @@ -498,32 +501,33 @@ (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) (debug:print 2 "Attempting to launch test " test-name "/" item-path) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) - (runs:update-test_meta db test-name test-conf))) + (open-run-close 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 (open-run-close db:get-test-id db run-id test-name item-path)) + (testdat (open-run-close 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)))) + (open-run-close tests:register-test db run-id test-name item-path) + (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)) + (set! testdat (open-run-close 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 @@ -568,11 +572,11 @@ (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat) "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override")) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. - (if (not (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags)) + (if (not (open-run-close launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))) ((KILLED) @@ -581,11 +585,11 @@ (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) (db:test-get-run_duration testdat))) 600) ;; i.e. no update for more than 600 seconds (begin (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - (test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) + (open-run-close test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) (debug:print 2 "NOTE: " test-name " is already running"))) (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))) ;;====================================================================== ;; END OF NEW STUFF 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 @@ -150,11 +152,11 @@ (if waived (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) - (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path real-status state)) + (db:test-set-state-status-by-run-id-testname db run-id test-name item-path real-status state)) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, do not rpc it (yet) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup db test-id status)) @@ -189,21 +191,21 @@ expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) - (rdb:csv->test-data db test-id + (db:csv->test-data db test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest - (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) + (db:roll-up-pass-fail-counts db run-id test-name item-path status) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (rdb:test-set-comment db test-id cmt))) + (db:test-set-comment db test-id cmt))) )) (define (test-set-toplog! db run-id test-name logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" logf run-id test-name)) @@ -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,29 +400,50 @@ ;; 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-set-meta-info db run-id testname itemdat) - (let ((item-path (item-list->path itemdat)) - (cpuload (get-cpu-load)) - (hostname (get-host-name)) - (diskfree (get-df (current-directory))) - (uname (get-uname "-srvpio"))) - (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=? WHERE run_id=? AND testname=? AND item_path=?;" - hostname - cpuload - diskfree - uname - run-id - testname - item-path))) +(define (test:tdb-get-rundat-count tdb) + (if tdb + (let ((res 0)) + (sqlite3:for-each-row + (lambda (count) + (set! res count)) + tdb + "SELECT count(id) FROM test_rundat;") + res)) + 0) + +(define (test-set-meta-info db test-id run-id testname itemdat #!key (minutes #f)) + (let* ((tdb (db:open-test-db-by-test-id db test-id)) + (num-records (test:tdb-get-rundat-count tdb)) + (item-path (item-list->path itemdat)) + (cpuload (get-cpu-load)) + (diskfree (get-df (current-directory)))) + (if (eq? (modulo num-records 10) 0) ;; every ten records update central + (begin + (sqlite3:execute db "UPDATE tests SET cpuload=?,diskfree=? WHERE run_id=? AND testname=? AND item_path=?;" + cpuload + diskfree + run-id + 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) + (if minutes + (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))) + ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -54,10 +54,14 @@ (test "register-test, test info" "NOT_STARTED" (begin (tests:register-test *db* 1 "nada" "") (vector-ref (db:get-test-info *db* 1 "nada" "") 3))) +(test #f "NOT_STARTED" + (begin + (open-run-close tests:register-test #f 1 "nada" "") + (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))) (test "get-keys" "SYSTEM" (vector-ref (car (db:get-keys *db*)) 0));; (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) (define remargs (args:get-args '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada") @@ -102,21 +106,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")