Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -674,11 +674,11 @@ 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)) ;; map run-id, testname item-path to test-id -(define (db:get-test-id db run-id testname item-path) +(define (db:get-test-cached-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 @@ -688,10 +688,22 @@ 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)))) + +;; map run-id, testname item-path to test-id +(define (db:get-test-id db run-id testname item-path) + (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 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) + res) + #f) ;; 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))) @@ -724,11 +736,11 @@ (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-info-by-id db test-id) +(define (db:get-test-info-cached-by-id db test-id) (if (not test-id) (begin (debug:print 4 "INFO: db:get-test-info-by-id called with test-id=" test-id) #f) (let ((res (hash-table-ref/default *test-info* test-id #f))) @@ -743,10 +755,26 @@ 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))))) + +;; Get test data using test_id +(define (db:get-test-info-by-id db test-id) + (if (not test-id) + (begin + (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) + ;; 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) + 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) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -213,10 +213,11 @@ (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 + (debug:print 4 "INFO: hed=" hed " at top of loop") (let* ((config (tests:get-testconfig hed 'return-procs)) (waitons (if config (string-split (let ((w (config-lookup config "requirements" "waiton"))) (if w w ""))) (begin (debug:print 0 "ERROR: non-existent required test \"" hed "\"") @@ -275,25 +276,27 @@ (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. + (debug:print 4 "INFO: test-records=" (hash-table->alist test-records)) (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 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))) + (item-patts (hash-table-ref/default flags "-itempatt" #f)) + (test-registery (make-hash-table))) (if (not (null? sorted-test-names)) (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names))) - (thread-sleep! *global-delta*) ;; give other applications some time with the db (let* ((test-record (hash-table-ref test-records hed)) + (test-name (tests:testqueue-get-testname test-record)) (tconfig (tests:testqueue-get-testconfig test-record)) (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) (if m (string->symbol m) 'normal))) (waitons (tests:testqueue-get-waitons test-record)) (priority (tests:testqueue-get-priority test-record)) @@ -319,21 +322,24 @@ (map (lambda (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 + "test-name: " test-name + "\n hed: " hed + "\n itemdat: " itemdat "\n items: " items "\n item-path: " item-path "\n waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error - (if (member hed waitons) + (if (member test-name waitons) (begin - (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") + (debug:print 0 "ERROR: test " test-name " 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 (open-run-close runs:can-run-more-tests #f test-record)) ;; look at the test jobgroup and tot jobs running @@ -345,29 +351,35 @@ (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) (conc " WARNING: t is not a vector=" t ))) prereqs-not-met) ", ") " fails: " fails) + (debug:print 4 "INFO: hed=" hed) ;; 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 - (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 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)) + ((not (patt-list-match item-path item-patts)) ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites - ) + (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + ((not (hash-table-ref/default test-registery (conc test-name "/" item-path) #f)) + (open-run-close tests:register-test #f run-id test-name item-path) + (hash-table-set! test-registery (conc test-name "/" item-path) #t) + (loop (car newtal)(cdr newtal))) ((not have-resources) ;; simply try again after waiting a second (thread-sleep! (+ 1 *global-delta*)) (debug:print 1 "INFO: no resources to run new tests, waiting ...") ;; could have done hed tal here but doing car/cdr of newtal to rotate tests (loop (car newtal)(cdr newtal))) + ((and have-resources + (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 + (run:test run-id runname keyvallst test-record flags #f)) (else ;; must be we have unmet prerequisites (debug:print 4 "FAILS: " fails) ;; If one or more of the prereqs-not-met are FAIL then we can issue ;; a message and drop hed from the items to be processed. (if (null? fails) @@ -498,18 +510,18 @@ (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 "") (db #f)) - (debug:print 5 + (debug:print 4 "test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) - (debug:print 2 "Attempting to launch test " test-name "/" item-path) + (debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "/") "/" item-path)) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) (open-run-close-measure set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) @@ -528,12 +540,17 @@ (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)) - (open-run-close tests:register-test db run-id test-name item-path) + ;; + ;; (open-run-close tests:register-test db run-id test-name item-path) + ;; + ;; NB// for the above line. I want the test to be registered long before this routine gets called! + ;; (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)) + (debug:print 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=" 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 Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -28,20 +28,21 @@ (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))) + (debug:print 4 "INFO: tests:register-test db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=" 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))) ;; 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)) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -20,11 +20,11 @@ test3 : fullprep cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b $(SERVER) -debug 10 test4 : fullprep - cd fullrun;$(MEGATEST) -debug 2 -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER) + cd fullrun;$(MEGATEST) -debug $(DEBUG) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER) test5 : fullprep cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_aa -v $(SERVER) 2&>1 aa.log & cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ab -v $(SERVER) 2&>1 ab.log & cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ac -v $(SERVER) 2&>1 ac.log &