Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -292,11 +292,11 @@ "-set-toplog" "-runstep" "-logpro" "-m" "-rerun" - "-kill-runs" + "-days" "-rename-run" "-to" ;; values and messages ":category" @@ -405,10 +405,11 @@ "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests, respects -testpatt, defaults to % "-run" ;; alias for -runall "-remove-runs" + "-kill-runs" "-keep-records" ;; use with -remove-runs to remove only the run data "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" @@ -1040,11 +1041,11 @@ (exit 1)) ((not (or (args:get-arg ":runname") (args:get-arg "-runname"))) (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the run name pattern with -runname patt") (exit 2)) - ((not (args:get-arg "-testpatt")) + ((not (or (args:get-arg "-testpatt") (eq? action 'kill-runs))) (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) (else (if (not (car *configinfo*)) (begin @@ -1067,11 +1068,20 @@ (if (args:get-arg "-kill-runs") (general-run-call "-kill-runs" "kill runs" (lambda (target runname keys keyvals) - (operate-on 'kill-runs mode: #f)))) + (operate-on 'kill-runs mode: #f) + + (operate-on 'set-state-status + state: (common:args-get-state) + status: (common:args-get-status) + new-state-status: (args:get-arg "-set-state-status") + + + mode: #f) ;; kill-req on running,launched,remotehoststart things, + ))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -2023,11 +2023,11 @@ (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) (bup-mutex (make-mutex)) (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". - (let* ((write-access-actions '(remove-runs set-state-status archive run-wait)) + (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) (dbfile (conc *toppath* "/megatest.db")) (readonly-mode (not (file-write-access? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") @@ -2061,20 +2061,18 @@ (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((kill-runs) - #f - (BB> "UNIMPLEMENTED: kill-runs");; TODO: BB implement it. - (exit 1) + (tasks:kill-runner target run-name "%") + (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname")) ) ((remove-runs) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here ;; (if (equal? testpatt "%") (tasks:kill-runner target run-name testpatt) - ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) @@ -2178,11 +2176,11 @@ (if (< (- now last-visit) 1.0) (thread-sleep! 1.0)) (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) ;; send to back of line, loop (let ((newtal (append tal (list test)))) - (loop (car newtal)(cdr newtal))) + (loop (car newtal)(cdr newtal))) ) ((done) ;; drop this one; if remaining, loop, else finish (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) (let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception))) @@ -2235,10 +2233,28 @@ (begin (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) (if (not (null? tal)) (loop (car tal)(cdr tal))))))) (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) + ((kill-runs) + ;; RUNNING -> KILLREQ + ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED + (cond + ((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))) + (common:send-thunk-to-background-thread + (lambda () + (let* ((subrun-remove-succeeded + (subrun:kill-subrun run-dir keep-records))) + #t))) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ) + ((member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ))) ((set-state-status) (let* ((new-state (car state-status)) (new-status (cadr state-status)) (test-id (db:test-get-id test)) (test-run-dir (db:test-get-rundir new-test-dat)) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -118,10 +118,19 @@ (begin (subrun:set-subrun-removed test-run-dir) #t) #f)) #t)) + +(define (subrun:kill-subrun test-run-dir ) + (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) + (let* ((action-switches-str + (conc "-kill-runs" )) + (kill-result + (subrun:exec-sub-megatest test-run-dir action-switches-str "kill"))) + kill-result) + #t)) (define (subrun:launch-cmd test-run-dir) (if (subrun:subrun-removed? test-run-dir) (subrun:unset-subrun-removed test-run-dir))