Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -519,10 +519,17 @@ (5 "COMPLETED") (6 "LAUNCHED") (7 "REMOTEHOSTSTART") (8 "RUNNING") )) + +(define *common:dont-roll-up-states* + '("DELETED" + "REMOVING" + "CLEANING" + "ARCHIVE_REMOVING" + )) ;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls ;; note these statuses are sorted from better to worse. ;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items (define *common:std-statuses* @@ -556,10 +563,16 @@ (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")) + +;; group tests into buckets corresponding to rollup +;;; Running, completed-pass, completed-non-pass + worst status, not started. +;; filter out +;(define (common:categorize-items-for-rollup in-tests) +; ( (define (common:special-sort items order comp) (let ((items-order (map reverse order)) (acomp (or comp >))) (sort items @@ -949,11 +962,11 @@ (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) (let* (;; (tagexpr (args:get-arg "-tagexpr")) ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) - (testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT")) + (testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig (if rconf Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -111,11 +111,12 @@ ;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature ;; first check for the switch ;; (if (or (args:get-arg "-rh5.11") - (configf:lookup *configdat* "dashboard" "no-detachbox")) + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) (set! iup:detachbox iup:vbox)) (if (not (common:on-homehost?)) (begin (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -3609,22 +3609,22 @@ ;; (non-completes (filter (lambda (x) ;; (not (equal? (dbr:counts-state x) "COMPLETED"))) ;; state-status-counts)) (all-curr-states (common:special-sort ;; worst -> best (sort of) (delete-duplicates - (if (not (equal? state "DELETED")) + (if (not (member state *common:dont-roll-up-states*)) (cons state (map dbr:counts-state state-status-counts)) (map dbr:counts-state state-status-counts))) *common:std-states* >)) (all-curr-statuses (common:special-sort ;; worst -> best (delete-duplicates - (if (not (equal? state "DELETED")) + (if (not (member state *common:dont-roll-up-states*)) (cons status (map dbr:counts-status state-status-counts)) (map dbr:counts-status state-status-counts))) *common:std-statuses* >)) (non-completes (filter (lambda (x) - (not (member x '("DELETED" "COMPLETED")))) + (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) all-curr-states)) (preq-fails (filter (lambda (x) (equal? x "PREQ_FAIL")) all-curr-statuses)) (num-non-completes (length non-completes)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -1533,11 +1533,11 @@ itemdat))) (testprevvals (alist->env-vars (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))) ;; Launchwait defaults to true, must override it to turn off wait (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) - (launch-results (apply (if launchwait + (launch-results (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed. process:cmd-run-with-stderr->list process-run) (if useshell (let ((cmdstr (string-intersperse fullcmd " "))) (if launchwait Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6504) +(define megatest-version 1.6505) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -128,11 +128,11 @@ -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs -testpatt patt1/patt2,patt3/... : % is wildcard -runname : required, name for this particular test run -state : Applies to runs, tests or steps depending on context -status : Applies to runs, tests or steps depending on context - --modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified + -modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified -tagexpr tag1,tag2%,.. : select tests with tags matching expression Test helpers (for use inside tests) -step stepname @@ -272,10 +272,11 @@ "-status" "-list-runs" "-testdata-csv" "-testpatt" "--modepatt" + "-modepatt" "-tagexpr" "-itempatt" "-setlog" "-set-toplog" "-runstep" Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -256,11 +256,11 @@ ;; given a mtutil param, return the old megatest equivalent ;; (define (param-translate param) (or (alist-ref (string->symbol param) '((-tag-expr . "-tagexpr") - (-mode-patt . "--modepatt") + (-mode-patt . "-modepatt") (-run-name . "-runname") (-test-patt . "-testpatt") (-msg . "-m") (-new . "-set-state-status"))) param)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -310,17 +310,11 @@ (system (conc run-post-hook " >> " actual-logf " 2>&1")) (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))))) ;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise. (define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon) - (let* ((tests-in-testpatt - (map - (lambda (test-patt-item) - (car (string-split test-patt-item "/"))) - (string-split test-patt ","))) - (waitors-upon-not-mentioned (lset-difference equal? waitors-upon tests-in-testpatt))) - (null? waitors-upon-not-mentioned))) + (null? (tests:filter-test-names-not-matched waitors-upon test-patt))) ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; @@ -426,12 +420,13 @@ ;; 1. fill required tests with test-patts ;; 2. scan testconfigs and if waitons, itemwait, itempatt calc prior test test-patt ;; 3. repeat until all deps propagated ;; any tests with direct mention in test-patts can be added to required + ;;(set! required-tests (lset-intersection equal? (string-split test-patts ",") all-test-names)) + (set! required-tests (tests:filter-test-names all-test-names test-patts)) ;; - (set! required-tests (lset-intersection equal? (string-split test-patts ",") all-test-names)) ;; (set! required-tests (lset-intersection equal? test-names all-test-names)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) @@ -1488,11 +1483,12 @@ items))) (let* ((items-in-testpatt (filter (lambda (my-itemdat) - (tests:match test-patts hed (item-list->path my-itemdat) required: required-tests)) + (tests:match test-patts hed (item-list->path my-itemdat) )) + ;; was: (tests:match test-patts hed (item-list->path my-itemdat) required: required-tests)) items) )) (if (null? items-in-testpatt) (let ((test-id (rmt:get-test-id run-id test-name ""))) (debug:print-info 0 *default-log-port* "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items matching test pattern -- marking status ZERO_ITEMS") (if test-id Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -74,10 +74,17 @@ (hash-table-set! test-registry tname test-path)))) (glob (conc hed "/*")))) (if (null? tal) test-registry (loop (car tal)(cdr tal)))))) + +(define (tests:filter-test-names-not-matched test-names test-patts) + (delete-duplicates + (filter (lambda (testname) + (not (tests:match test-patts testname #f))) + test-names))) + (define (tests:filter-test-names test-names test-patts) (delete-duplicates (filter (lambda (testname) (tests:match test-patts testname #f))