Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -610,13 +610,11 @@ (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) (if (process:alive-on-host? test-host test-pid) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") - ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") - (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) - )) + (exit))) ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -110,11 +110,12 @@ Launching and managing runs -run : run all tests or as specified by -testpatt -remove-runs : remove the data for a run, requires -runname and -testpatt Optionally use :state and :status, use -keep-records to remove only the run data. - -kill-runs : kill an existing run (all incomplete tests marked abort, launched marked not-started) + -kill-runs : kill existing run(s) (all incomplete tests killed) + -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun) -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs -rerun FAIL,WARN... : force re-run for tests with specificed status(s) -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a and then run the specified testpatt with -preclean -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean @@ -406,10 +407,11 @@ "-runall" ;; run all tests, respects -testpatt, defaults to % "-run" ;; alias for -runall "-remove-runs" "-kill-runs" + "-kill-rerun" "-keep-records" ;; use with -remove-runs to remove only the run data "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" @@ -574,11 +576,11 @@ (process:children #f)) (original-exit exit-code))))) ;; for some switches always print the command to stderr ;; -(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs") +(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun") (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) ;; some switches imply homehost. Exit here if not on homehost ;; (let ((homehost-required (list "-cleanup-db" "-server"))) @@ -1070,10 +1072,38 @@ "-kill-runs" "kill runs" (lambda (target runname keys keyvals) (operate-on 'kill-runs mode: #f) ))) + +(if (args:get-arg "-kill-rerun") + (let* ((target-patt (args:get-arg "-target")) + (runname-patt (args:get-arg "-runname"))) + (cond ((not target-patt) + (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ") + (exit 1)) + ((not runname-patt) + (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ") + (exit 1)) + ((string-search "[ ,%]" target-patt) + (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ") + (exit 1)) + ((string-search "[ ,%]" runname-patt) + (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ") + (exit 1)) + (else + (general-run-call + "-kill-runs" + "kill runs" + (lambda (target runname keys keyvals) + (operate-on 'kill-runs mode: #f) + )) + + (thread-sleep! 15)) + ;; fall thru and let "-run" loop fire + ))) + (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" @@ -1633,18 +1663,19 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (or (args:get-arg "-runall") (args:get-arg "-run") (args:get-arg "-rerun-clean") (args:get-arg "-rerun-all") - (args:get-arg "-runtests")) + (args:get-arg "-runtests") + (args:get-arg "-kill-rerun")) (let ((need-clean (or (args:get-arg "-rerun-clean") (args:get-arg "-rerun-all")))) (general-run-call "-runall" "run all tests" (lambda (target runname keys keyvals) - (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct + (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct ;; For rerun-clean do we or do we not support the testpatt? (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -141,10 +141,11 @@ run : initiate or resume a run, already completed and in-progress tests are not affected. rerun-clean : clean and rerun all not completed pass/fail tests rerun-all : clean and rerun entire run kill-run : kill all tests in run + kill-rerun : kill all tests in run and restart non-completed tests remove : remove runs set-ss : set state/status archive : compress and move test data to archive disk kill : stop tests or entire runs db : database utilities @@ -249,10 +250,11 @@ (define *action-keys* '((run . "-run") (rerun-clean . "-rerun-clean") (rerun-all . "-rerun-all") (kill-run . "-kill-runs") + (kill-rerun . "-kill-rerun") (sync . "") (archive . "-archive") (set-ss . "-set-state-status") (remove . "-remove-runs"))) @@ -1445,11 +1447,11 @@ (set! *default-log-port* oup) ))) (if *action* (case (string->symbol *action*) - ((run remove rerun rerun-clean rerun-all set-ss archive kill list kill-run) + ((run remove rerun rerun-clean rerun-all set-ss archive kill list kill-run kill-rerun) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section (areasec (if area (configf:lookup mtconf "areas" area) #f)) (areadat (if areasec (common:val->alist areasec) #f))