Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -349,22 +349,23 @@ ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* - '((0 "RUNNING") - (1 "COMPLETED") - (2 "REMOTEHOSTSTART") - (3 "LAUNCHED") + '((0 "ARCHIVED") + (1 "STUCK") + (2 "KILLREQ") + (3 "KILLED") (4 "NOT_STARTED") - (5 "KILLED") - (6 "KILLREQ") - (7 "STUCK") - (8 "ARCHIVED"))) + (5 "RUNNING") + (6 "LAUNCHED") + (7 "REMOTEHOSTSTART") + (8 "COMPLETED") + )) (define *common:std-statuses* - '((0 "DELETED") + '(;; (0 "DELETED") (1 "n/a") (2 "PASS") (3 "CHECK") (4 "SKIP") (5 "WARN") Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -286,11 +286,12 @@ (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (rmt:test-set-state-status-by-id run-id test-id state #f #f) + ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) + (rmt:roll-up-pass-fail-counts run-id test-id #f state #f) ;; test-name passed in as test-id is respected (db:test-set-state! testdat state))))) btn)) (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -319,11 +320,12 @@ (iup:attribute-set! wtxtbox "VALUE" c) (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) )))) (begin - (rmt:test-set-state-status-by-id run-id test-id #f status #f) + ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) + (rmt:roll-up-pass-fail-counts run-id test-id #f #f status) ;; test-name passed in as test-id is respected (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -3174,31 +3174,44 @@ (mt:process-triggers run-id test-id state status))) ;; state is the priority rollup of all states ;; status is the priority rollup of all completed states ;; -(define (db:roll-up-items-state-status dbstruct run-id test-name item-path state status) +;; if test-name is an integer work off that instead of test-name test-path +;; +(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status #!key (comment #f)) (let* ((db (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) - (testdat (db:get-test-info dbstruct run-id test-name "")) - (test-id (db:test-get-id testdat))) + (testdat1 (if (number? test-name) + (db:get-test-info-by-id dbstruct run-id test-name) + #f)) + (orig-test-id (db:test-get-id testdat1)) ;; the item + (test-name (db:test-get-testname testdat1)) + (testdat (db:get-test-info dbstruct run-id test-name "")) + (test-id (db:test-get-id testdat)) + (item-path (db:test-get-item-path testdat1))) (sqlite3:with-transaction db (lambda () - (let* ((all-curr-states (common:special-sort - (cons state (db:get-all-item-states db run-id test-name)) - *common:std-states* >)) - (all-curr-statuses (common:special-sort - (let ((statuses (db:get-all-item-statuses db run-id test-name))) - (if (equal? state "COMPLETED") - (cons status statuses) - statuses)) - *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)))) - (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus #f)))))) - -(define db:roll-up-pass-fail-counts db:roll-up-items-state-status) + (db:test-set-state-status-by-id dbstruct run-id orig-test-id state status comment) + (if (not (equal? item-path "")) ;; only roll up IF we are 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 (equal? state "COMPLETED") + (cons status statuses) + statuses))) + *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)))) + (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus #f))))))) + +(define db:roll-up-pass-fail-counts db:set-state-status-and-roll-up-items) ;; call with state = #f to roll up with out accounting for state/status of this item ;; ;; (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status) ;; (if (not (equal? item-path "")) ;; if asked to do this for a specific item then do an incremental update Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -240,11 +240,11 @@ ;; Since we should have a clean slate at this time there is no need to do ;; any of the other stuff that tests:test-set-status! does. Let's just ;; force RUNNING/n/a ;; (thread-sleep! 0.3) - (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") + ;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -353,10 +353,11 @@ (pop-directory) result))))) (define (tests:test-force-state-status! run-id test-id state status) (rmt:test-set-status-state run-id test-id status state #f) + ;; (rmt:roll-up-pass-fail-counts run-id test-name item (mt:process-triggers run-id test-id state status)) ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) (let* ((real-status status)