Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -3865,88 +3865,94 @@ ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) - (if (eq? mode 'exclusive) - (let ((running-tests (db:get-tests-for-run dbstruct - #f ;; run-id of #f means for all runs. - (if (string=? ref-item-path "") - ref-test-name - (conc ref-test-name "/" ref-item-path)) - '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") - '() - #f - #f - 'shortlist - 0 ;; last update, beginning of time .... - #f))) - running-tests) - (if (or (not waitons) - (null? waitons)) - '() - (let* ((unmet-pre-reqs '()) - (result '())) - (for-each - (lambda (waitontest-name) - ;; by getting the tests with matching name we are looking only at the matching test - ;; and related sub items - ;; next should be using mt:get-tests-for-run? - (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) - (ever-seen #f) - (parent-waiton-met #f) - (item-waiton-met #f)) - (for-each - (lambda (test) - ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... - (let* ((state (db:test-get-state test)) - (status (db:test-get-status test)) - (item-path (db:test-get-item-path test)) - (is-completed (equal? state "COMPLETED")) - (is-running (equal? state "RUNNING")) - (is-killed (equal? state "KILLED")) - (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) - ;; testname-b path-a path-b - (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) - (set! ever-seen #t) - (cond - ;; case 1, non-item (parent test) is - ((and (equal? item-path "") ;; this is the parent test of the waiton being examined - is-completed - (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) - (set! parent-waiton-met #t)) - ;; Special case for toplevel and KILLED - ((and (equal? item-path "") ;; this is the parent test - is-killed - (member 'toplevel mode)) - (set! parent-waiton-met #t)) - ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met - ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ????? - ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items - same-itempath) - (if (and is-completed is-ok) - (set! item-waiton-met #t)) - (if (and (equal? item-path "") - (or is-completed is-running));; this is the parent, set it to run if completed or running - (set! parent-waiton-met #t))) - ;; normal checking of parent items, any parent or parent item not ok blocks running - ((and is-completed - (or is-ok - (member 'toplevel mode)) ;; toplevel does not block on FAIL - (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok - (set! item-waiton-met #t))))) - tests) - ;; both requirements, parent and item-waiton must be met to NOT add item to - ;; prereq's not met list - (if (not (or parent-waiton-met item-waiton-met)) - (set! result (append (if (null? tests) (list waitontest-name) tests) result))) - ;; if the test is not found then clearly the waiton is not met... - ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) - (if (not ever-seen) - (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) - waitons) - (delete-duplicates result))))) + (append + (if (member 'exclusive mode) + (let ((running-tests (db:get-tests-for-run dbstruct + #f ;; run-id of #f means for all runs. + (if (string=? ref-item-path "") ;; testpatt + ref-test-name + (conc ref-test-name "/" ref-item-path)) + '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states + '() ;; statuses + #f ;; offset + #f ;; limit + #f ;; not-in + #f ;; sort by + #f ;; sort order + 'shortlist ;; query type + 0 ;; last update, beginning of time .... + #f ;; mode + ))) + (map db:test-get-testname running-tests)) + '()) + (if (or (not waitons) + (null? waitons)) + '() + (let* ((unmet-pre-reqs '()) + (result '())) + (for-each + (lambda (waitontest-name) + ;; by getting the tests with matching name we are looking only at the matching test + ;; and related sub items + ;; next should be using mt:get-tests-for-run? + (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) + (ever-seen #f) + (parent-waiton-met #f) + (item-waiton-met #f)) + (for-each + (lambda (test) + ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... + (let* ((state (db:test-get-state test)) + (status (db:test-get-status test)) + (item-path (db:test-get-item-path test)) + (is-completed (equal? state "COMPLETED")) + (is-running (equal? state "RUNNING")) + (is-killed (equal? state "KILLED")) + (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) + ;; testname-b path-a path-b + (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) + (set! ever-seen #t) + (cond + ;; case 1, non-item (parent test) is + ((and (equal? item-path "") ;; this is the parent test of the waiton being examined + is-completed + (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) + (set! parent-waiton-met #t)) + ;; Special case for toplevel and KILLED + ((and (equal? item-path "") ;; this is the parent test + is-killed + (member 'toplevel mode)) + (set! parent-waiton-met #t)) + ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met + ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ????? + ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items + same-itempath) + (if (and is-completed is-ok) + (set! item-waiton-met #t)) + (if (and (equal? item-path "") + (or is-completed is-running));; this is the parent, set it to run if completed or running + (set! parent-waiton-met #t))) + ;; normal checking of parent items, any parent or parent item not ok blocks running + ((and is-completed + (or is-ok + (member 'toplevel mode)) ;; toplevel does not block on FAIL + (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok + (set! item-waiton-met #t))))) + tests) + ;; both requirements, parent and item-waiton must be met to NOT add item to + ;; prereq's not met list + (if (not (or parent-waiton-met item-waiton-met)) + (set! result (append (if (null? tests) (list waitontest-name) tests) result))) + ;; if the test is not found then clearly the waiton is not met... + ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) + (if (not ever-seen) + (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) + waitons) + (delete-duplicates result))))) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;====================================================================== Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -533,35 +533,13 @@ (set! *didsomething* #t))) ;; handle a clean-cache request as early as possible ;; (if (args:get-arg "-clean-cache") - (begin + (let ((toppath (launch:setup))) (set! *didsomething* #t) ;; suppress the help output. - (if (getenv "MT_TARGET") ;; no point in trying if no target - (if (args:get-arg "-runname") - (let* ((toppath (launch:setup)) - (linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree"))) - (runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname"))) - (files (if (file-exists? runtop) - (append (glob (conc runtop "/.megatest*")) - (glob (conc runtop "/.runconfig*"))) - '()))) - (if (null? files) - (debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.") - (begin - (debug:print-info 0 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n ")) - (for-each - (lambda (f) - (handle-exceptions - exn - (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f) - (delete-file f))) - files)))) - (debug:print-error 0 *default-log-port* "-clean-cache requires -runname.")) - (debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg")))) - + (runs:clean-cache (getenv "MT_TARGET")(args:get-arg "-runname" toppath)))) (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) @@ -1455,10 +1433,11 @@ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") state: states ;; status: statuses new-state-status: "NOT_STARTED,n/a") + (runs:clean-cache target runname *toppath*) (runs:operate-on 'set-state-status target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") ;; state: states @@ -1473,10 +1452,11 @@ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") state: #f ;; status: statuses new-state-status: "NOT_STARTED,n/a") + (runs:clean-cache target runname *toppath*) (runs:operate-on 'set-state-status target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") ;; state: states Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -145,10 +145,11 @@ ("-version" . #f) ;; misc ("-repl" . #f) ("-immediate" . I) ("-preclean" . r) + ("-rerun-all" . u) )) ;; alist to map actions to old megatest commands (define *action-keys* '((run . "-run") @@ -511,11 +512,12 @@ (if (not (or mode-patt tag-expr)) `(("-testpatt" . "%")) '()) (if (or (not action) (equal? action "run")) - `(("-preclean" . " ")) ;; if run we *always* want preclean set, use single space as placeholder + `(("-preclean" . " ") + ("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder '()) ) sched))) (with-output-to-file (conc pktsdir "/" uuid ".pkt") Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -2076,5 +2076,28 @@ (db:test-get-id testdat)))) )) prev-tests))) +;; clean cache files +(define (runs:clean-cache target runname toppath) + (if target + (if runname + (let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree"))) + (runtop (conc linktree "/" target "/" runname)) + (files (if (file-exists? runtop) + (append (glob (conc runtop "/.megatest*")) + (glob (conc runtop "/.runconfig*"))) + '()))) + (if (null? files) + (debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.") + (begin + (debug:print-info 0 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n ")) + (for-each + (lambda (f) + (handle-exceptions + exn + (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f) + (delete-file f))) + files)))) + (debug:print-error 0 *default-log-port* "-clean-cache requires -runname.")) + (debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg"))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -192,13 +192,13 @@ exn (current-seconds) ;; 0 (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted (down-time (- (current-seconds) mod-time)) (serv-dat (if (or (< num-serv-logs 10) - (< down-time day-seconds)) - (server:logf-get-start-info hed) - '())) ;; don't waste time processing server files not touched in the past day if there are more than ten servers to look at + (< down-time 900)) ;; day-seconds)) + (server:logf-get-start-info hed) + '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at (serv-rec (cons mod-time serv-dat)) (fmatch (string-match fname-rx hed)) (pid (if fmatch (string->number (list-ref fmatch 2)) #f)) (new-res (if (null? serv-dat) res