Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -17,21 +17,21 @@ (define (api:execute-requests dbstruct cmd params) (case (string->symbol cmd) ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) - ((get-keys) (db:get-keys db)) + ((get-keys) (db:get-keys dbstruct)) ;; TESTS ;; json doesn't do vectors, convert to list ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) - ((get-count-tests-running) (db:get-count-tests-running db)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) ((db:test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) ((test-get-records-for-index-file (apply db:test-get-records-for-index-file dbstruct params))) @@ -45,11 +45,11 @@ ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) - ((get-test-id) (apply db:get-test-id-not-cached dbstruct params)) + ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -63,13 +63,13 @@ ;; 'read read data ;; (define (db:done-with dbstruct run-id mod-read) (mutex-lock! *rundb-mutex*) (if (eq? mod-read 'mod) - (dbr:dbstruct-set-runvec! dbstruct run-id 'mtime (current-milliseconds)) - (dbr:dbstruct-set-runvec! dbstruct run-id 'rtime (current-milliseconds))) - (dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #f) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'mtime (current-milliseconds)) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'rtime (current-milliseconds))) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'inuse #f) (mutex-unlock! *rundb-mutex*)) ;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; @@ -122,16 +122,16 @@ (if write-access (begin (sqlite3:set-busy-handler! db handler) (sqlite3:execute db "PRAGMA synchronous = 0;"))) (if (not dbexists)(db:initialize-run-id-db db)) - (dbr:dbstruct-set-runvec! dbstruct run-id 'rundb db) - (dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #t) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'rundb db) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'inuse #t) (if local db (begin - (dbr:dbstruct-set-runvec! dbstruct run-id 'inmem inmem) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'inmem inmem) (db:sync-tables db:sync-tests-only db inmem) inmem)))))) ;; This routine creates the db. It is only called if the db is not already opened ;; @@ -203,12 +203,12 @@ '("testname" #f) '("host" #f) '("cpuload" #f) '("diskfree" #f) '("uname" #f) - '("rundir" #f) - '("shortdir" #f) + '("rundir_id" #f) + '("shortdir_id" #f) '("item_path" #f) '("state" #f) '("status" #f) '("attemptnum" #f) '("final_logf" #f) @@ -262,12 +262,12 @@ '("testname" #f) '("host" #f) '("cpuload" #f) '("diskfree" #f) '("uname" #f) - '("rundir" #f) - '("shortdir" #f) + '("rundir_id" #f) + '("shortdir_id" #f) '("item_path" #f) '("state" #f) '("status" #f) '("attemptnum" #f) '("final_logf" #f) @@ -479,12 +479,12 @@ testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, uname TEXT DEFAULT 'n/a', - rundir TEXT DEFAULT 'n/a', - shortdir TEXT DEFAULT '', + rundir_id INTEGER DEFAULT -1, + shortdir_id INTEGER DEFAULT -1, item_path TEXT DEFAULT '', state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'FAIL', attemptnum INTEGER DEFAULT 0, final_logf TEXT DEFAULT 'logs/final.log', @@ -1109,11 +1109,11 @@ ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match (define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) (let* ((qryvalstr (case qryvals ((shortlist) "id,run_id,testname,item_path,state,status") - ((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + ((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir_id,item_path,run_duration,final_logf,comment") (else qryvals))) (res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f @@ -1182,40 +1182,44 @@ -1 "" -1 -1 "" "-" (vector-ref inrec 3) ;; item-path -1 "-" "-")) -(define (db:get-tests-for-run-state-status db run-id testpatt) +(define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) - (sqlite3:for-each-row - (lambda (id testname item-path state status) - ;; 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 -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) - db - qry - run-id) + (db:with-db dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id testname item-path state status) + ;; 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 -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + db + qry + run-id))) res)) -(define (db:get-testinfo-state-status db test-id) +(define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) - (sqlite3:for-each-row - (lambda (run-id testname item-path state status) - ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) - db - "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" - test-id) + (db:with-db dbstruct #f + (lambda (db) + (sqlite3:for-each-row + (lambda (run-id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + db + "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" + test-id))) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} -(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) - (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) +(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states status not-in) + (db:get-tests-for-runs dbstruct run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; (define (db:delete-test-records dbstruct run-id test-id) @@ -1328,21 +1332,21 @@ (db:get-db dbstruct run-id) "SELECT id FROM tests WHERE testname=? AND item_path=?;" testname item-path) res)) -(define db:test-record-qry-selector "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir_id,item_path,run_duration,final_logf,comment,realdir_id") +(define db:test-record-qry-selector "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir_id,item_path,run_duration,final_logf,comment,shortdir_id") ;; NOTE: Use db:test-get* to access records ;; NOTE: This needs rundir_id decoding? Decide, decode here or where used? For the moment decode where used. (define (db:get-all-tests-info-by-run-id dbstruct run-id) (let ((db (db:get-db dbstruct run-id)) (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-id item-path run-duration final_logf comment short-dir-id) ;; 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-id item-path run-duration final_logf comment short-dir-id) res))) (db:get-db dbstruct run-id) (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE run_id=?;") run-id) res)) @@ -1350,13 +1354,13 @@ ;; Get test data using test_id (define (db:get-test-info-by-id dbstruct run-id test-id) (let ((db (db:get-db dbstruct run-id)) (res #f)) (sqlite3:for-each-row - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id) + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment short-dir-id) ;; 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-id item-path run_duration final_logf comment realdir-id))) + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment short-dir-id))) (db:get-db dbstruct run-id) (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)) @@ -1365,13 +1369,13 @@ ;; (define (db:get-test-info-by-ids dbstruct run-id test-ids) (let ((db (db:get-db dbstruct run-id)) (res '())) (sqlite3:for-each-row - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id) + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment short-dir-id) ;; 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-id item-path run_duration final_logf comment realdir-id) + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment short-dir-id) res))) (db:get-db dbstruct run-id) (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)) @@ -1904,11 +1908,11 @@ (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items ;; next should be using mt:get-tests-for-run? - (let ((tests (db:get-tests-for-run-state-status db run-id waitontest-name)) + (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -16,19 +16,33 @@ (make-hash-table) ;; run-id => [ rundb inmemdb last-mod last-read last-sync ] #f ;; the global string db (use for state, status etc.) path ;; path to database files/megatest area local)) ;; read-only local access +;; +;; Accessors for a dbstruct +;; ;; get and set main db (define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) (define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db)) +;; get the runs hash +(define-inline (dbr:dbstruct-get-dbhash vec) (vector-ref vec 1)) +;; the string db +(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2)) +(define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db)) +;; path +(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3)) +(define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3)) +;; local +(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4)) +(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val)) -;; get a rundb vector +;; get a rundb vector, create it if not already existing (define (dbr:dbstruct-get-rundb-rec vec run-id) - (let* ((dbhash (vector-ref vec 1)) - (runvec (hash-table-ref/default dbhash run-id #f))) - (if runvec + (let* ((dbhash (dbr:dbstruct-get-dbhash vec)) ;; get the runs hash + (runvec (hash-table-ref/default dbhash run-id #f))) ;; get the vector for run-id + (if (vector? runvec) runvec (let ((nvec (vector #f #f -1 -1 -1 #f))) (hash-table-set! dbhash run-id nvec) nvec)))) @@ -42,19 +56,19 @@ ((stime) 4) ;; last sync time ((inuse) 5) ;; is the db currently in use (else -1))) ;; get/set rundb fields -(define (dbr:dbstruct-get-runvec vec run-id field-name) +(define (dbr:dbstruct-get-runvec-val vec run-id field-name) (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)) (fieldnum (dbr:dbstruct-field-name->num field-name))) ;; (vector-set! runvec (dbr:dbstruct-field-name->num 'inuse) #t) (vector-ref runvec fieldnum))) -(define (dbr:dbstruct-set-runvec! vec run-id field-name val) +(define (dbr:dbstruct-set-runvec-val! vec run-id field-name val) (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) - (vector-set! runvec (dbr:dbstruct-field-name->num field-name) runvec))) + (vector-set! runvec (dbr:dbstruct-field-name->num field-name) val))) ;; get/set inmemdb (define (dbr:dbstruct-get-inmemdb vec run-id) (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) (vector-ref runvec 1))) @@ -61,22 +75,10 @@ (define (dbr:dbstruct-set-inmemdb! vec run-id inmemdb) (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) (vector-set! runvec 1 inmemdb))) -;; the string db -(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2)) -(define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db)) - -;; path -(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3)) -(define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3)) - -;; local -(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4)) -(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val)) - (define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -309,11 +309,11 @@ start-seconds))))) (kill-tries 0)) (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) (let loop ((minutes (calc-minutes))) (begin - (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat)) + (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) (time-exceeded (> run-seconds runtlim))) (if time-exceeded (begin (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) @@ -345,11 +345,11 @@ ;; (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") - (tests:test-set-status! test-id "KILLED" "FAIL" + (tests:test-set-status! run-id test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (exit 1) ;; IS THIS NECESSARY OR WISE??? ))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) @@ -500,11 +500,11 @@ (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))) ;; Update the rundir path in the test record for all ;; (cdb:test-set-rundir-by-test-id *runremote* test-id (filedb:register-path *fdb* lnkpathf)) - (rmt:general-call 'test-set-rundir-by-test-id lnkpathf test-id) + (rmt:general-call 'test-set-rundir-by-test-id run-id lnkpathf test-id) (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) @@ -520,16 +520,16 @@ ;; 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 (rmt:get-test-info-by-id test-id)) ;; run-id testname item-path)) + (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo (filedb:get-path *fdb* (db:test-get-rundir testinfo)) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? ;;(cdb:test-set-rundir! *runremote* run-id testname "" (filedb:register-path *fdb* lnkpath)) ;; toptest-path) - (rmt:general-call 'test-set-rundir lnkpath run-id testname "") ;; toptest-path) + (rmt:general-call 'test-set-rundir run-id lnkpath run-id testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) (create-directory toptest-path #t) @@ -661,11 +661,11 @@ (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (item-path (item-list->path itemdat)) ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (testinfo (rmt:get-test-info-by-id test-id)) + (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) (setenv "MT_ITEMPATH" item-path) (if hosts (set! hosts (string-split hosts))) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -158,20 +158,20 @@ ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; speed up for common cases with a little logic -(define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment) +(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) - (rmt:general-call 'state-status-msg newstate newstatus newcomment test-id)) + (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) ((and newstate newstatus) - (rmt:general-call 'state-status newstate newstatus test-id)) + (rmt:general-call 'state-status run-id newstate newstatus test-id)) (else - (if newstate (rmt:general-call 'set-test-state newstate test-id)) - (if newstatus (rmt:general-call 'set-test-status newstatus test-id)) - (if newcomment (rmt:general-call 'set-test-comment newcomment test-id)))) + (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) + (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) + (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (mt:process-triggers test-id newstate newstatus) #t) (define (mt:lazy-get-test-info-by-id test-id) (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -106,26 +106,26 @@ ;;====================================================================== (define (rmt:get-test-id run-id testname item-path) (rmt:send-receive 'get-test-id (list run-id testname item-path))) -(define (rmt:get-test-info-by-id test-id) - (rmt:send-receive 'get-test-info-by-id (list test-id))) +(define (rmt:get-test-info-by-id run-id test-id) + (rmt:send-receive 'get-test-info-by-id (list run-id test-id))) -(define (rmt:test-get-rundir-from-test-id test-id) - (rmt:send-receive 'test-get-rundir-from-test-id (list test-id))) +(define (rmt:test-get-rundir-from-test-id run-id test-id) + (rmt:send-receive 'test-get-rundir-from-test-id (list run-id test-id))) -(define (rmt:open-test-db-by-test-id test-id #!key (work-area #f)) +(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area - (rmt:test-get-rundir-from-test-id test-id)))) + (rmt:test-get-rundir-from-test-id run-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system -(define (rmt:test-set-state-status-by-id test-id newstate newstatus newcomment) - (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment))) +(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) + (rmt:send-receive 'test-set-state-status-by-id (list run-id test-id newstate newstatus newcomment))) (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (rmt:send-receive 'set-tests-state-status (list run-id testnames currstate currstatus newstate newstatus))) (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) @@ -132,15 +132,15 @@ (rmt:send-receive 'get-tests-for-run (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))) (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) (rmt:send-receive 'get-tests-for-runs-mindata (list run-ids testpatt states status not-in))) -(define (rmt:delete-test-records test-id) - (rmt:send-receive 'delete-test-records (list test-id))) +(define (rmt:delete-test-records run-id test-id) + (rmt:send-receive 'delete-test-records (list run-id test-id))) -(define (rmt:test-set-status-state test-id status state msg) - (rmt:send-receive 'test-set-status-state (list test-id status state msg))) +(define (rmt:test-set-status-state run-id test-id status state msg) + (rmt:send-receive 'test-set-status-state (list run-id test-id status state msg))) (define (rmt:get-previous-test-run-record run-id test-name item-path) (rmt:send-receive 'get-previous-test-run-record (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) @@ -150,15 +150,15 @@ (rmt:send-receive 'test-get-logfile-info (list run-id test-name))) (define (rmt:test-get-records-for-index-file run-id test-name) (rmt:send-receive 'test-get-records-for-index-file (list run-id test-name))) -(define (rmt:get-testinfo-state-status test-id) - (rmt:send-receive 'get-testinfo-state-status (list test-id))) +(define (rmt:get-testinfo-state-status run-id test-id) + (rmt:send-receive 'get-testinfo-state-status (list run-id test-id))) -(define (rmt:test-set-log! test-id logf) - (if (string? logf)(rmt:general-call 'test-set-log logf test-id))) +(define (rmt:test-set-log! run-id test-id logf) + (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (rmt:send-receive 'test-get-paths-matching-keynames-target-new (list keynames target res testpatt statepatt statuspatt runname))) (define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) @@ -167,15 +167,15 @@ (define (rmt:get-count-tests-running-for-run-id run-id) (rmt:send-receive 'get-count-tests-running-for-run-id (list run-id))) ;; Statistical queries -(define (rmt:get-count-tests-running) - (rmt:send-receive 'get-count-tests-running '())) +(define (rmt:get-count-tests-running run-id) + (rmt:send-receive 'get-count-tests-running (list run-id))) -(define (rmt:get-count-tests-running-in-jobgroup jobgroup) - (rmt:send-receive 'get-count-tests-running-in-jobgroup (list jobgroup))) +(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) + (rmt:send-receive 'get-count-tests-running-in-jobgroup (list run-id jobgroup))) (define (rmt:roll-up-pass-fail-counts run-id test-name item-path status) (rmt:send-receive 'roll-up-pass-fail-counts (list run-id test-name item-path status))) (define (rmt:update-pass-fail-counts run-id test-name) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -159,16 +159,16 @@ (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) -(define (runs:can-run-more-tests jobgroup max-concurrent-jobs) +(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((num-running (rmt:get-count-tests-running)) - (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup jobgroup)) + (let* ((num-running (rmt:get-count-tests-running run-id)) + (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin @@ -377,11 +377,11 @@ (define runs:nothing-left-in-queue-count 0) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print-info 4 "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed @@ -576,17 +576,17 @@ (else (conc t)))) inlst)) (define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry) - (let* ((run-limits-info (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (loop-list (list hed tal reg reruns))) (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse @@ -622,20 +622,20 @@ ;; ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) (if (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (begin - (rmt:general-call 'register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name item-path) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)) (let ((th (make-thread (lambda () (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) (mutex-unlock! registry-mutex) ;; If haven't done it before register a top level test if this is an itemized test (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (rmt:general-call 'register-test run-id test-name "")) - (rmt:general-call 'register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name "")) + (rmt:general-call 'register-test run-id run-id test-name item-path) (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) (mutex-unlock! registry-mutex)) (conc test-name "/" item-path)))) (thread-start! th))) @@ -814,11 +814,11 @@ ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) (begin - (rmt:general-call 'register-test run-id test-name "") + (rmt:general-call 'register-test run-id run-id test-name "") (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) @@ -930,11 +930,11 @@ ;; 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 ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) + (let ((can-run-more (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records))) (if loop-list (apply loop loop-list))) @@ -1037,11 +1037,11 @@ (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (test-id (rmt:get-test-id run-id test-name item-path)) - (testdat (if test-id (rmt:get-test-info-by-id test-id) #f))) + (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) (if (not testdat) (let loop () ;; 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)) @@ -1052,14 +1052,14 @@ ;; (if (not test-id)(set! test-id (rmt:get-test-id-cached run-id test-name item-path))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:general-call 'register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name item-path) (set! test-id (rmt:get-test-id run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (set! testdat (rmt:get-test-info-by-id test-id)) + (set! testdat (rmt:get-test-info-by-id run-id test-id)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) @@ -1134,11 +1134,11 @@ (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) (if skip-test (begin - (mt:test-set-state-status-by-id test-id "COMPLETED" "SKIP" skip-test) + (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; @@ -1260,11 +1260,11 @@ (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) - (new-test-dat (rmt:get-test-info-by-id test-id))) + (new-test-dat (rmt:get-test-info-by-id run-id test-id))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) @@ -1289,21 +1289,21 @@ ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") - (mt:test-set-state-status-by-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) (thread-sleep! 1)) (begin - (mt:test-set-state-status-by-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) (thread-sleep! 1))) ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... (if (null? tal) (loop new-test-dat tal) (loop (car tal)(append tal (list new-test-dat))))) (begin - (mt:test-set-state-status-by-id (db:test-get-id test) "REMOVING" "LOCKED" #f) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "REMOVING" "LOCKED" #f) (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) @@ -1336,11 +1336,11 @@ (rmt:delete-test-records (db:test-get-id test)) (if (not (null? tal)) (loop (car tal)(cdr tal)))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) - (mt:test-set-state-status-by-id (db:test-get-id test) (car state-status)(cadr state-status) #f) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -196,14 +196,14 @@ (define (tests:test-force-state-status! test-id state status) (rmt:test-set-status-state test-id status state #f) (mt:process-triggers test-id state status)) ;; Do not rpc this one, do the underlying calls!!! -(define (tests:test-set-status! test-id state status comment dat #!key (work-area #f)) +(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) - (testdat (rmt:get-test-info-by-id test-id)) + (testdat (rmt:get-test-info-by-id run-id 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 @@ -288,14 +288,14 @@ (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (rmt:general-call 'set-test-comment cmt test-id))))) + (rmt:general-call 'set-test-comment run-id cmt test-id))))) (define (tests:test-set-toplog! run-id test-name logf) - (rmt:general-call 'tests:test-set-toplog logf run-id test-name)) + (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name)) (define (tests:summarize-items run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename @@ -588,12 +588,12 @@ ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here -(define (test-get-kill-request test-id) ;; run-id test-name itemdat) - (let* ((testdat (rmt:get-test-info-by-id test-id))) +(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat) + (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) (and testdat (equal? (test:get-state testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count tdb) (if tdb @@ -604,25 +604,25 @@ tdb "SELECT count(id) FROM test_rundat;") res)) 0) -(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname) - (rmt:general-call 'update-cpuload-diskfree cpuload diskfree test-id) +(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname) + (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id) (if minutes - (rmt:general-call 'update-run-duration minutes test-id)) + (rmt:general-call 'update-run-duration run-id minutes test-id)) (if (and uname hostname) - (rmt:general-call 'update-uname-host uname hostname test-id))) + (rmt:general-call 'update-uname-host run-id uname hostname test-id))) (define (tests:set-full-meta-info test-id run-id minutes work-area) (let* ((num-records 0) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes) - (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname))) + (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) (define (tests:set-partial-meta-info test-id run-id minutes work-area) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes))) Index: tests/unittests/dbrdbstruct.scm ================================================================== --- tests/unittests/dbrdbstruct.scm +++ tests/unittests/dbrdbstruct.scm @@ -10,12 +10,24 @@ (define dbstruct (make-dbr:dbstruct "/tmp")) (test #f #t (begin (dbr:dbstruct-set-main! dbstruct "blah") #t)) (test #f "blah" (dbr:dbstruct-get-main dbstruct)) -(test #f #t (vector? (dbr:dbstruct-get-rundb-rec dbstruct 1))) +(for-each + (lambda (run-id) + (test #f #t (vector? (dbr:dbstruct-get-rundb-rec dbstruct run-id)))) + (list 1 2 3 4 5 6 7 8 9 #f)) + +(test #f 0 (dbr:dbstruct-field-name->num 'rundb)) +(test #f 1 (dbr:dbstruct-field-name->num 'inmem)) +(test #f 2 (dbr:dbstruct-field-name->num 'mtime)) + +(test #f #f (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) +(test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 'rundb "rundb") #t)) +(test #f "rundb" (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) (for-each (lambda (k) - (test #f #t (begin (dbr:dbstruct-set-runvec! dbstruct 1 k (conc k)) #t)) - (test #f k (dbr:dbstruct-get-runvec dbstruct 1 k))) + (test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 k (conc k)) #t)) + (test #f (conc k) (dbr:dbstruct-get-runvec-val dbstruct 1 k))) '(rundb inmem mtime rtime stime inuse)) +