@@ -207,11 +207,11 @@ ;; 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 (test:get-testconfig hed 'return-procs)) + (let* ((config (tests:get-testconfig hed 'return-procs)) (waitons (string-split (let ((w (config-lookup config "requirements" "waiton"))) (if w w ""))))) ;; (items (items:get-items-from-config config))) (if (not (hash-table-ref/default test-records hed #f)) (hash-table-set! test-records @@ -242,11 +242,11 @@ (debug:print 4 "INFO: items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config config)) (else #f))) ;; not iterated #f ;; itemsdat 5 - ;; #f ;; spare + #f ;; spare - used for item-path ))) (for-each (lambda (waiton) (if (and waiton (not (member waiton test-names))) (begin @@ -262,10 +262,11 @@ ;; 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)) (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) ;; 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) (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) @@ -275,11 +276,11 @@ (tal (cdr sorted-test-names))) (let* ((test-record (hash-table-ref test-records hed)) (tconfig (tests:testqueue-get-testconfig test-record)) (waitons (tests:testqueue-get-waitons test-record)) (priority (tests:testqueue-get-priority test-record)) - (itemdat (tests:testqueue-get-itemdat test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat))) (debug:print 6 "itemdat: " itemdat "\n items: " items @@ -295,11 +296,11 @@ ;; no loop - drop though and use the loop at the bottom (run:test db run-id runname keyvallst test-record flags #f) ;; else the run is stuck, temporarily or permanently (let ((newtal (append tal (list hed)))) ;; couldn't run, take a breather - (thread-sleep! 4) + (thread-sleep! 0.5) (loop (car newtal)(cdr newtal)))))) ;; case where an items came in as a list been processed ((and (list? items) ;; thus we know our items are already calculated (not itemdat)) ;; and not yet expanded into the list of things to be done @@ -312,10 +313,13 @@ (lambda (my-itemdat) (let* ((new-test-record (let ((newrec (make-tests:testqueue))) (vector-copy! test-record newrec) newrec)) (my-item-path (item-list->path my-itemdat)) + + ;; 3/25/2012 - this match is *always* returning true I believe. Or is it the tests that are not being handled? + ;; (item-matches (if item-patts ;; here we are filtering for matches with -itempatt (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % (for-each (lambda (patt) (if (string-search (glob->regexp @@ -324,13 +328,14 @@ (set! res #t))) (string-split item-patts ",")) res) #t))) (if item-matches ;; yes, we want to process this item - (let ((newtestname (conc hed "/" my-item-path))) - (tests:testqueue-set-items! new-test-record #f) - (tests:testqueue-set-itemdat! new-test-record my-itemdat) + (let ((newtestname (conc hed "/" my-item-path))) ;; test names are unique on testname/item-path + (tests:testqueue-set-items! new-test-record #f) + (tests:testqueue-set-itemdat! new-test-record my-itemdat) + (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath items) (loop (car tal)(cdr tal))) @@ -351,11 +356,11 @@ (begin (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") (exit 1))))) (let ((newtal (append tal (list hed)))) ;; if can't run more tests, lets take a breather - (thread-sleep! 1) + (thread-sleep! 0.5) (loop (car newtal)(cdr newtal))))) ;; this case should not happen, added to help catch any bugs ((and (list? items) itemdat) (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") @@ -364,22 +369,29 @@ ;; we get here on "drop through" - loop for next test in queue (if (null? tal) (begin ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! (debug:print 1 "INFO: All tests launched") - ;; (exit 0) - ) - (loop (car tal)(cdr tal)))))) + (thread-sleep! 0.5) + ;; 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, + (thread-sleep! 0.5) + (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) ;; 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 test:get-testconfig here ... + (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 "")) (debug:print 5