Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -403,15 +403,24 @@ (6 "WAIVED") (7 "STUCK/DEAD") (8 "FAIL") (9 "ABORT"))) -(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed +(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE")) (define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked - '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE")) + '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD")) + +(define *common:running-states* ;; test is either running or can be run + '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED")) + +(define *common:cant-run-states* ;; These are stopping conditions that prevent a test from being run + '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED")) + +(define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead + '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP")) (define (common:special-sort items order comp) (let ((items-order (map reverse order)) (acomp (or comp >))) (sort items @@ -418,66 +427,62 @@ (lambda (a b) (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) (b-num (cadr (or (assoc b items-order) '(0 0))))) (acomp a-num b-num)))))) -;; These are stopping conditions that prevent a test from being run -(define *common:cant-run-states-sym* - '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED)) - -;; given a toplevel with currstate, currstatus apply state and status -;; => (newstate . newstatus) -(define (common:apply-state-status currstate currstatus state status) - (let* ((cstate (string->symbol (string-downcase currstate))) - (cstatus (string->symbol (string-downcase currstatus))) - (sstate (string->symbol (string-downcase state))) - (sstatus (string->symbol (string-downcase status))) - (nstate #f) - (nstatus #f)) - (set! nstate - (case cstate - ((completed not_started killed killreq stuck archived) - (case sstate ;; completed -> sstate - ((completed killed killreq stuck archived) completed) - ((running remotehoststart launched) running) - (else unknown-error-1))) - ((running remotehoststart launched) - (case sstate - ((completed killed killreq stuck archived) #f) ;; need to look at all items - ((running remotehoststart launched) running) - (else unknown-error-2))) - (else unknown-error-3))) - (set! nstatus - (case sstatus - ((pass) - (case nstate - ((pass n/a deleted) pass) - ((warn) warn) - ((fail) fail) - ((check) check) - ((waived) waived) - ((skip) skip) - ((stuck/dead) stuck) - ((abort) abort) - (else unknown-error-4))) - ((warn) - (case nstate - ((pass warn n/a skip deleted) warn) - ((fail) fail) - ((check) check) - ((waived) waived) - ((stuck/dead) stuck) - (else unknown-error-5))) - ((fail) - (case nstate - ((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail) - ((abort) abort) - (else unknown-error-6))) - (else unknown-error-7))) - (cons - (if nstate (symbol->string nstate) nstate) - (if nstatus (symbol->string nstatus) nstatus)))) +;; ;; given a toplevel with currstate, currstatus apply state and status +;; ;; => (newstate . newstatus) +;; (define (common:apply-state-status currstate currstatus state status) +;; (let* ((cstate (string->symbol (string-downcase currstate))) +;; (cstatus (string->symbol (string-downcase currstatus))) +;; (sstate (string->symbol (string-downcase state))) +;; (sstatus (string->symbol (string-downcase status))) +;; (nstate #f) +;; (nstatus #f)) +;; (set! nstate +;; (case cstate +;; ((completed not_started killed killreq stuck archived) +;; (case sstate ;; completed -> sstate +;; ((completed killed killreq stuck archived) completed) +;; ((running remotehoststart launched) running) +;; (else unknown-error-1))) +;; ((running remotehoststart launched) +;; (case sstate +;; ((completed killed killreq stuck archived) #f) ;; need to look at all items +;; ((running remotehoststart launched) running) +;; (else unknown-error-2))) +;; (else unknown-error-3))) +;; (set! nstatus +;; (case sstatus +;; ((pass) +;; (case nstate +;; ((pass n/a deleted) pass) +;; ((warn) warn) +;; ((fail) fail) +;; ((check) check) +;; ((waived) waived) +;; ((skip) skip) +;; ((stuck/dead) stuck) +;; ((abort) abort) +;; (else unknown-error-4))) +;; ((warn) +;; (case nstate +;; ((pass warn n/a skip deleted) warn) +;; ((fail) fail) +;; ((check) check) +;; ((waived) waived) +;; ((stuck/dead) stuck) +;; (else unknown-error-5))) +;; ((fail) +;; (case nstate +;; ((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail) +;; ((abort) abort) +;; (else unknown-error-6))) +;; (else unknown-error-7))) +;; (cons +;; (if nstate (symbol->string nstate) nstate) +;; (if nstatus (symbol->string nstatus) nstatus)))) ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -43,10 +43,18 @@ ;; each db entry is a pair ( db . dbfilepath ) (defstruct dbr:dbstruct (tmpdb #f) (mtdb #f) (refndb #f)) + +;; record for keeping state,status and count for doing roll-ups in +;; iterated tests +;; +(defstruct dbr:counts + (state #f) + (status #f) + (count 0)) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== @@ -3140,27 +3148,35 @@ (sqlite3:with-transaction db (lambda () (db:test-set-state-status-by-id dbstruct run-id test-id state status comment) (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item - (let* ((all-curr-states (common:special-sort - (delete-duplicates - (let ((states (db:get-all-item-states db run-id test-name))) - (if state (cons state states) states))) - *common:std-states* >)) - (all-curr-statuses (common:special-sort - (delete-duplicates - (let ((statuses (db:get-all-item-statuses db run-id test-name))) - (if (member state *common:ended-states*) ;; '("COMPLETED" "ARCHIVED")) - (cons (if (member state *common:badly-ended-states*) - "FAIL" - status) - statuses) - statuses))) + (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test + (running (length (filter (lambda (x) + (member (dbr:counts-state x) *common:running-states*)) + state-status-counts))) + (bad-not-started (length (filter (lambda (x) + (and (equal? (dbr:counts-state x) "NOT_STARTED") + (not (member (dbr:counts-status x) + *common:not-started-ok-statuses*)))) + state-status-counts))) + (all-curr-states (common:special-sort ;; worst -> best (sort of) + (delete-duplicates + (cons state (map dbr:counts-state state-status-counts))) + *common:std-states* >)) + (all-curr-statuses (common:special-sort ;; worst -> best + (delete-duplicates + (cons status (map dbr:counts-status state-status-counts))) *common:std-statuses* >)) - (newstate (if (null? all-curr-states) "NOT_STARTED" (car all-curr-states))) - (newstatus (if (null? all-curr-statuses) "n/a" (car all-curr-statuses)))) + (newstate (if (> running 0) + "RUNNING" + (if (> bad-not-started 0) + "COMPLETED" + (car all-curr-states)))) + (newstatus (if (> bad-not-started 0) + "CHECK" + (car all-curr-statuses)))) ;; (print "Setting toplevel to: " newstate "/" newstatus) (db:test-set-state-status-by-id dbstruct run-id tl-test-id newstate newstatus #f))))))) (define db:roll-up-pass-fail-counts db:set-state-status-and-roll-up-items) @@ -3201,10 +3217,19 @@ ;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) ;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) ;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) ;; ;; #f) ;; ;; ))) + +(define (db:get-all-state-status-counts-for-test db run-id test-name item-path) + (sqlite3:map-row + (lambda (state status count) + (make-dbr:counts state: state status: status count: count)) + db + "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" + run-id test-name item-path)) + (define (db:get-all-item-states db run-id test-name) (sqlite3:map-row (lambda (a) a) db