Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -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 Index: test_records.scm ================================================================== --- test_records.scm +++ test_records.scm @@ -1,16 +1,19 @@ ;; make-vector-record tests testqueue testname testconfig waitons priority items -(define (make-tests:testqueue)(make-vector 6 #f)) +(define (make-tests:testqueue)(make-vector 7 #f)) (define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0)) (define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1)) (define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2)) (define-inline (tests:testqueue-get-priority vec) (vector-ref vec 3)) ;; items: #f=no items, list=list of items remaining, proc=need to call to get items (define-inline (tests:testqueue-get-items vec) (vector-ref vec 4)) (define-inline (tests:testqueue-get-itemdat vec) (vector-ref vec 5)) +(define-inline (tests:testqueue-get-item_path vec) (vector-ref vec 6)) (define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val)) (define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val)) (define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val)) (define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val)) (define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val)) (define-inline (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val)) +(define-inline (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val)) + Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -285,11 +285,11 @@ (if (file-exists? (conc testpath "/testconfig")) (set! res (cons (last (string-split testpath "/")) res)))) tests) res)) -(define (test:get-testconfig test-name system-allowed) +(define (tests:get-testconfig test-name system-allowed) (let* ((test-path (conc *toppath* "/tests/" test-name)) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))) (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed @@ -337,10 +337,47 @@ #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go #f)))))))) +;; for each test: +;; +(define (tests:filter-non-runnable db run-id testkeynames testrecordshash) + (let ((runnables '())) + (for-each + (lambda (testkeyname) + (let* ((test-record (hash-table-ref testrecordshash testkeyname)) + (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))) + (if tdat + (begin + ;; Look at the test state and status + (if (or (member (db:test-get-status tdat) + '("PASS" "WARN" "WAIVED" "CHECK")) + (member (db:test-get-state tdat) + '("INCOMPLETE" "KILLED"))) + (set! keep-test #f)) + + ;; 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 ""))) + (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 + waitons)))) + (if keep-test (set! runnables (cons testkeyname runnables))))) + testkeynames) + runnables)) ;;====================================================================== ;; test steps ;;======================================================================