Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -374,10 +374,13 @@ (8 "FAIL") (9 "ABORT"))) (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")) (define (common:special-sort items order comp) (let ((items-order (map reverse order)) (acomp (or comp >))) (sort items Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -287,11 +287,11 @@ (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:roll-up-pass-fail-counts run-id test-id #f state #f) ;; test-name passed in as test-id is respected + (rmt:roll-up-pass-fail-counts run-id test-id #f state #f #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) @@ -321,11 +321,11 @@ (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:roll-up-pass-fail-counts run-id test-id #f #f status) ;; test-name passed in as test-id is respected + (rmt:roll-up-pass-fail-counts run-id test-id #f #f status #f) ;; 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 @@ -3176,11 +3176,11 @@ ;; state is the priority rollup of all states ;; status is the priority rollup of all completed states ;; ;; 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)) +(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) ;; establish info on incoming test followed by info on top level test (let* ((db (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) (testdat (if (number? test-name) (db:get-test-info-by-id dbstruct run-id test-name) (db:get-test-info dbstruct run-id test-name item-path))) @@ -3189,11 +3189,10 @@ (db:test-get-testname testdat) test-name)) (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (db:test-get-id tl-testdat))) - (print "Got here.") (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 @@ -3204,11 +3203,14 @@ *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 status statuses) + (cons (if (member state *common:badly-ended-states*) + "FAIL" + 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)))) (print "Setting toplevel to: " newstate "/" newstatus) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -241,11 +241,11 @@ ;; 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") - (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") + (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING" #f) ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) @@ -1118,12 +1118,13 @@ (debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; + ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) - (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "LAUNCHED") + (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "LAUNCHED" #f) (set! diskpath (get-best-disk *configdat* tconfig)) (if diskpath (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -177,25 +177,29 @@ (begin (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) (print-call-chain (current-error-port)) #f) (begin - (cond - ((and newstate newstatus newcomment) - (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) - ((and newstate newstatus) - (rmt:general-call 'state-status run-id newstate newstatus test-id)) - (else - (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) - (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) - (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) + ;; cond + ;; ((and newstate newstatus newcomment) + ;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) + ;; ((and newstate newstatus) + ;; (rmt:general-call 'state-status run-id newstate newstatus test-id)) + ;; (else + ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) + ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) + ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) + (rmt:roll-up-pass-fail-counts run-id test-id #f newstate newstatus newcomment) (mt:process-triggers run-id 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 (rmt:get-test-id run-id test-name item-path))) - (mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) + (rmt:roll-up-pass-fail-counts run-id test-name item-path new-state new-status new-comment) + (mt:process-triggers run-id test-id new-state new-status) + #t)) + ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) (if tconf tconf Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -520,12 +520,12 @@ (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) ;; state and status are extra hints not usually used in the calculation ;; -(define (rmt:roll-up-pass-fail-counts run-id test-name item-path state status) - (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path state status))) +(define (rmt:roll-up-pass-fail-counts run-id test-name item-path state status comment) + (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path state status comment))) (define (rmt:update-pass-fail-counts run-id test-name) (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) (define (rmt:top-test-set-per-pf-counts run-id test-name) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -928,11 +928,11 @@ (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) ;; (debug:print 0 *default-log-port* " 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) ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. - (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL") ;; treat as FAIL + (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) tal reg reruns))))) ;; can't drop this - maybe running? Just keep trying Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -397,11 +397,12 @@ ;; update the primary record IF state AND status are defined (if (and state status) (begin (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment)) - (mt:process-triggers run-id test-id state real-status))) + (mt:process-triggers run-id test-id state real-status) + )) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) (rmt:test-data-rollup run-id test-id status)) @@ -442,11 +443,11 @@ (rmt:csv->test-data run-id test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) - (rmt:roll-up-pass-fail-counts run-id test-name item-path state status)) + (rmt:roll-up-pass-fail-counts run-id test-name item-path state status #f)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) @@ -481,11 +482,11 @@ (let loop ((have-lock (common:simple-file-lock lockf))) (if have-lock (let ((script (configf:lookup *configdat* "testrollup" test-name))) (print "Obtained lock for " outputfilename) ;; (rmt:top-test-set-per-pf-counts run-id test-name) - (rmt:roll-up-pass-fail-counts run-id test-name "" #f #f) + (rmt:roll-up-pass-fail-counts run-id test-name "" #f #f #f) (rmt:top-test-set-per-pf-counts run-id test-name) (if script (system (conc script " > " outputfilename " & ")) (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)) (common:simple-file-release-lock lockf)