Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -2064,10 +2064,11 @@ (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) (run-dir ;;(filedb:get-path *fdb* ;; (rmt:sdb-qry 'getid (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree + (has-subrun (subrun:subrun-test-initialized? run-dir)) (test-state (db:test-get-state new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat)) (uname (db:test-get-uname new-test-dat)) (toplevel-with-children (and (db:test-get-is-toplevel test) (> (rmt:test-toplevel-num-items run-id test-name) 0)))) @@ -2081,10 +2082,16 @@ (if (> (hash-table-ref toplevel-retries test-fulln) 3) (if (not (null? tal)) (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries (let ((newtal (append tal (list test)))) (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue + (has-subrun + ;; BB TODO - manage toplevasel-retries hash and retries in general + (subrun:remove-subrun test-run-dir new-test-dat test-name item-path test-state test-fulln toplevel-with-children test) + + + ) (else (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state) (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) (begin (if (not (hash-table-ref/default test-retry-time test-fulln #f)) @@ -2110,22 +2117,25 @@ (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))) ((set-state-status) + ;; BB TODO - manage has-subrun case (debug:print-info 2 *default-log-port* "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) + ;; BB TODO - manage has-subrun case (debug:print-info 2 *default-log-port* "still waiting, " (length tests) " tests still running") (thread-sleep! 10) (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) (debug:print-info 1 *default-log-port* "Run completed according to zero tests matching provided criteria.") (loop (car new-tests)(cdr new-tests))))) ((archive) + ;; BB TODO - manage has-subrun case (if (and run-dir (not toplevel-with-children)) (let ((ddir (conc run-dir "/"))) (case (string->symbol (args:get-arg "-archive")) ((save save-remove keep-html) (if (common:file-exists? ddir) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -28,10 +28,18 @@ ;;(include "key_records.scm") ;;(include "db_records.scm") ;;(include "run_records.scm") ;;(include "test_records.scm") +(define (subrun:subrun-test-initialized? test-run-dir) + (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) + (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) + #t + #f)) + +(define (subrun:testconfig-defines-subrun? testconfig) + (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested (define (subrun:initialize-toprun-test testconfig test-run-dir) (let ((ra (configf:lookup testconfig "subrun" "run-area")) (logpro (configf:lookup testconfig "subrun" "logpro")) @@ -48,26 +56,48 @@ (create-symbolic-link ra symlink-target) (configf:write-alist testconfig "testconfig.subrun"))) + +(define (subrun:remove-subrun test-run-dir new-test-dat test-name item-path test-state test-fulln toplevel-with-children test) +;; set state/status of test item +;; fork off megatest +;; set state/status of test item +;; + + (let* ((subrun-alist (subrun:selector+log-alist test-run-dir log-prefix)) + (runlog (alist-ref "-log" subrun-alist equal? #f))) + (if (not (common:file-exists? runlog)) + (BB> "no runlog @ "runlog) + (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first + ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give + ;; up and blow it away. + + ;; call in submegatest: + ;; (tasks:kill-runner target run-name testpatt) + + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "SUBRUN-KILLREQ" "n/a" #f) + ) + + ;; on success: + ;; set state of test, or delete it or whatever + ) + ) + ) (define (subrun:launch-cmd test-run-dir) (let* ((log-prefix "run") (switches (subrun:selector+log-switches test-run-dir log-prefix)) (run-wait #t) (cmd (conc "megatest -run "switches" " (if run-wait "-run-wait " "")))) cmd)) -;; set state/status of test item -;; fork off megatest -;; set state/status of test item -;; - -(define (subrun:selector+log-switches test-run-dir log-prefix) +(define (subrun:selector+log-alist test-run-dir log-prefix) (let* ((switch-def-alist (common:get-param-mapping flavor: 'config)) (subrunfile (conc test-run-dir "/testconfig.subrun" )) (subrundata (with-input-from-file subrunfile read)) (subrunconfig (configf:alist->config subrundata)) (run-area (configf:lookup subrunconfig "subrun" "run-area")) @@ -117,23 +147,31 @@ (map (lambda (item) (if (equal? (car item) "-testpatt") (cons "-testpatt" testpatt) item)) switch-alist-pre)))) + switch-alist)) ;; note - get precmd from subrun section ;; apply to submegatest commands - (let* ((res - (string-intersperse - (apply - append - (map - (lambda (x) - (list (car x) (cdr x))) - switch-alist)) - " "))) - res))) - + +(define (subrun:get-log-path test-run-dir log-prefix) + (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix)) + (res (alist-ref "-log" alist equal? #f))) + res)) + +(define (subrun:selector+log-switches test-run-dir log-prefix) + (let* ((switch-alist (subrun:selector+log-alist test-run-dir log-prefix)) + (res + (string-intersperse + (apply + append + (map + (lambda (x) + (list (car x) (cdr x))) + switch-alist)) + " "))) + res)) (define (subrun:exec-sub-megatest test-run-dir switches #!key (logfile #f)) (let* ((real-logfile (or logfile (conc (test-run-dir) "/subrun-" (string-substitute "[/*]" "_" (string-intersperse switches "^"))"-" (number->string (current-seconds)) ".log")))