Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1689,11 +1689,11 @@ (define (cdb:top-test-set-running serverdat run-id test-name) (cdb:client-call serverdat 'top-test-set-running #t *default-numtries* run-id test-name)) (define (cdb:top-test-set-per-pf-counts serverdat run-id test-name) - (cdb:client-call serverdat 'top-test-set-per-pf-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name)) + (cdb:client-call serverdat 'top-test-set-per-pf-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name run-id test-name)) ;;= (define (cdb:flush-queue serverdat) (cdb:client-call serverdat 'flush #f *default-numtries*)) @@ -1788,13 +1788,18 @@ '(top-test-set-per-pf-counts "UPDATE tests SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' + AND status NOT IN ('TEN_STRIKES','BLOCKED') AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' ELSE 'COMPLETED' END, status=CASE + WHEN (SELECT count(id) FROM tests + WHERE run_id=? AND testname=? + AND item_path != '' + AND state IN ('NOT_STARTED','BLOCKED')) > 0 THEN 'FAIL' WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -184,10 +184,14 @@ (if newstate (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id)) (if newstatus (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id)) (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id)))) (mt:process-triggers test-id newstate newstatus) #t) + +(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) + (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) + (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) (define (mt:lazy-get-test-info-by-id test-id) (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) (if (and tdat (< (current-seconds)(+ (vector-ref tdat 0) 10))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -576,23 +576,28 @@ ((and (not (null? fails))(member 'toplevel testmode)) (if (or (not (null? reg))(not (null? tal))) (list (car newtal)(append (cdr newtal) reg) '() reruns) #f)) (else - (debug:print 1 "WARNING: FAILS or incomplete tests are preventing completion of this run. Dropping test " hed " from the run queue") - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns))))) ;; (list (car newtal)(cdr newtal) reg reruns))))) + (debug:print 0 "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") + ;; (list (runs:queue-next-hed tal reg reglen regfull) + ;; (runs:queue-next-tal tal reg reglen regfull) + ;; (runs:queue-next-reg tal reg reglen regfull) + ;; reruns) + (list (car newtal)(cdr newtal) reg reruns))))) (define (runs:mixed-list-testname-and-testrec->list-of-strings inlst) (if (null? inlst) '() (map (lambda (t) (cond ((vector? t) - (conc (db:test-get-state t) "/" (db:test-get-status t))) + (let ((test-name (db:test-get-testname t)) + (item-path (db:test-get-item-path t)) + (test-state (db:test-get-state t)) + (test-status (db:test-get-status t))) + (conc test-name (if (equal? item-path "") "" "/") item-path ":" test-state "/" test-status))) ((string? t) t) (else (conc t)))) inlst))) @@ -734,15 +739,16 @@ (thread-sleep! 1) (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (if (or (not (null? reg))(not (null? tal))) (if (vector? hed) - (begin - (debug:print 1 "WARNING: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) + (begin + (debug:print 1 "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? @@ -772,28 +778,51 @@ (runs:queue-next-tal newtal reg reglen regfull) (runs:queue-next-reg newtal reg reglen regfull) reruns)) ((symbol? nth-try) (debug:print 0 "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.") + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) (hash-table-set! test-registry hed 0) (list (runs:queue-next-hed newtal reg reglen regfull) (runs:queue-next-tal newtal reg reglen regfull) (runs:queue-next-reg newtal reg reglen regfull) reruns)) (else (debug:print 0 "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.") ;; (debug:print 0 " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) + (mt:roll-up-pass-fail-counts run-id test-name item-path "FAIL") ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) tal reg reruns))))) ;; can't drop this - maybe running? Just keep trying - (list hed - tal - reg - reruns))))))) + (let ((runable-tests (runs:runable-tests prereqs-not-met))) + (if (null? runable-tests) + #f ;; I think we are truly done here + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns))))))))) + +;; scan a list of tests looking to see if any are potentially runnable +(define (runs:runable-tests tests) + (filter (lambda (t) + (if (not (vector? t)) + t + (let ((state (db:test-get-state t)) + (status (db:test-get-status t))) + (case (string->symbol state) + ((COMPLETED) #f) + ((NOT_STARTED) + (if (member status '("TEN_STRIKES" "BLOCKED")) + #f + t)) + ((DELETED) #f) + (else t))))) + tests)) ;; every time though the loop increment the test/itempatt val. ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table))