Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -950,17 +950,17 @@ "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) WHERE run_id=? AND testname=? AND item_path='';" run-id test-name run-id test-name run-id test-name) - (thread-sleep! 0.1) ;; give other processes a chance here - (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING - (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name) + ;; (thread-sleep! 0.1) ;; give other processes a chance here + (if (member status '("NOT_STARTED" "LAUNCHED" "RUNNING" "REMOTEHOSTSTART")) ;; running takes priority over all other states, force the test state to RUNNING + (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" status run-id test-name) (sqlite3:execute db "UPDATE tests - SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN + SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' ELSE 'COMPLETED' END, status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END WHERE run_id=? AND testname=? AND item_path='';" run-id test-name run-id test-name)) @@ -1075,11 +1075,11 @@ (debug:print 4 lin) (rdb:csv->test-data db test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status to - (rdb:test-data-rollup db test-id #f)) + (db:test-data-rollup db test-id #f)) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; 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. @@ -1222,11 +1222,11 @@ (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items - (let ((tests (rdb:get-tests-for-run db run-id waitontest-name #f '() '())) + (let ((tests (open-run-close db:get-tests-for-run db run-id waitontest-name #f '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) @@ -1237,15 +1237,16 @@ (is-completed (equal? state "COMPLETED")) (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED"))) (same-itempath (equal? ref-item-path item-path))) (set! ever-seen #t) (cond - ;; case 1, non-item (parent test) is + ;; case 1, non-item (parent test) is completed and ok ((and (equal? item-path "") ;; this is the parent test is-completed (or is-ok (eq? mode 'toplevel))) (set! parent-waiton-met #t)) + ;; ((and same-itempath is-completed (or is-ok (eq? mode 'toplevel))) (set! item-waiton-met #t))))) tests) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -280,11 +280,11 @@ (system (conc "kill -9 " pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") (open-run-close test-set-status! #f test-id "KILLED" "FAIL" (args:get-arg "-m") #f) - (sqlite3:finalize! tdb) + ;; (sqlite3:finalize! tdb) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) ;; (sqlite3:finalize! db) (thread-sleep! (+ 10 (random 10))) ;; add some jitter to the call home time to spread out the db accesses @@ -332,12 +332,12 @@ (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) + ;; (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) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -278,10 +278,31 @@ (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 run-id runname test-records keyvallst flags) (debug:print 4 "INFO: All done by here"))) + +;; testname is hed and remtests is tal, can be testname strings or testqueue vectors +;; remaining-items are other items for the current test that have not been run yet +;; this is used in calculating the state of toplevel tests. They are NOT COMPLETED +;; until all items are COMPLETED and thus not in this list. +(define (runs:remaining-items testdat remtests) + (let* ((testname (tests:testqueue-get-testname testdat)) ;; extract the name of the test (may have vector record) + (itempath (tests:testqueue-get-itempath testdat)) + (toptestname (if (string? testname) + (car (string-split testname "/")) + (begin + (debug:print 0 "ERROR: Should have a string testname here! Please report this as a bug :(") + testname)))) + (filter (lambda (test) + (let ((tname (tests:testqueue-get-testname test)) + (ipath (tests:testqueue-get-itempath test))) + (and (equal? tname testname) + (and (not (equal? ipath "")) + (not (equal? ipath itempath)))))) + remtests))) + ;; 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)) @@ -335,11 +356,11 @@ (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 - (prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) + (prereqs-not-met (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) @@ -359,26 +380,29 @@ (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 + ((not have-resources) + ;; simply try again after waiting a second, but register the test + ;; so the itemized tests have place holders + (open-run-close tests:register-test db run-id (tests:testqueue-get-testname hed) item-path) (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))) + (loop hed tal)) ;; (car newtal)(cdr newtal))) WHY DID I REORDER!!? (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) (begin ;; couldn't run, take a breather (debug:print 4 "INFO: Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") (thread-sleep! (+ 1 *global-delta*)) ;; long sleep here - no resources, may as well be patient - ;; we made new tal by sticking hed at the back of the list - (loop (car newtal)(cdr newtal))) + ;; we made new tal by sticking hed at the back of the list. BUT WHY? + (loop hed tal)) ;; (car newtal)(cdr newtal))) ;; the waiton is FAIL so no point in trying to run hed ever again (if (not (null? tal)) (if (vector? hed) (begin (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) " from the launch list as it has prerequistes that are FAIL") @@ -445,11 +469,11 @@ (tests:testqueue-set-items! test-record items-list) (loop hed tal)) (begin (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") (exit 1)))))) - ((null? fails) + ((null? fails) ;; AGAIN, WHY DID I TRY TO ROTATE THE TESTS HERE? (loop (car newtal)(cdr newtal))) ;; an issue with prereqs not yet met? ((and (not (null? fails))(eq? testmode 'normal)) (debug:print 1 "INFO: test " hed " (mode=" testmode ") has failed prerequisite(s); " (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") ", removing it from to-do list") Index: test_records.scm ================================================================== --- test_records.scm +++ test_records.scm @@ -1,16 +1,22 @@ ;; make-vector-record tests testqueue testname testconfig waitons priority items (define (make-tests:testqueue)(make-vector 7 #f)) -(define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0)) + +;; modified to treat the param either as a string (pure name) or vec (testqueue record) +(define-inline (tests:testqueue-get-testname vec) + (if (string? vec) (car (string-split 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-get-item_path vec) + (if (string? vec) + (let ((tmp (cdr (string-split vec "/")))) + (if (null? tmp) "" (car tmp)) + (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)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -371,27 +371,26 @@ (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")) - (member (db:test-get-state tdat) - '("INCOMPLETE" "KILLED"))) + (if (or (and (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK")) + (equal? (db:test-get-state tdat) "COMPLETED")) + (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* ((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"))) + (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") + (member (db:test-get-status wtdat) '("FAIL"))) + (member (db:test-get-status wtdat) '("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))