Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -99,10 +99,32 @@ ;;====================================================================== ;; Misc utils ;;====================================================================== +;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 +(define (common:hms-string->seconds tstr) + (let ((parts (string-split tstr)) + (time-secs 0) + ;; s=seconds, m=minutes, h=hours, d=days + (trx (regexp "(\\d+)([smhd])"))) + (for-each (lambda (part) + (let ((match (string-match trx part))) + (if match + (let ((val (string->number (cadr match))) + (unt (caddr match))) + (if val + (set! time-secs (+ time-secs (* val + (case (string->symbol unt) + ((s) 1) + ((m) 60) + ((h) (* 60 60)) + ((d) (* 24 60 60)) + (else 0)))))))))) + parts) + time-secs)) + (define (common:version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) ;; one-of args defined (define (args-defined? . param) @@ -180,11 +202,11 @@ ;; (define (common:max inlst) (let loop ((max-val (car inlst)) (hed (car inlst)) (tal (cdr inlst))) - (if (null? tal) + (if (not (null? tal)) (loop (max hed max-val) (car tal) (cdr tal)) (max hed max-val)))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -918,10 +918,11 @@ (define (dashboard:one-run) (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" + #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id (cdr run-path)))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2142,18 +2142,24 @@ ;; (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-killed (equal? state "KILLED")) (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) (same-itempath (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 is-completed (or is-ok (member mode '(toplevel itemmatch)))) + (set! parent-waiton-met #t)) + ;; Special case for toplevel and KILLED + ((and (equal? item-path "") ;; this is the parent test + is-killed + (eq? mode 'toplevel)) (set! parent-waiton-met #t)) ((or (and (not same-itempath) (eq? mode 'itemmatch)) ;; in itemmatch mode we look only at the same itempath (and same-itempath is-completed Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -71,10 +71,11 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) + (runtlim (assoc/default 'runtlim cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (keys #f) (keyvals #f) (fullrunscript (if (not runscript) #f @@ -274,33 +275,41 @@ (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) (begin - (set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat)) + (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat)) + (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) + (time-exceeded (> run-seconds runtlim))) + (if time-exceeded + (begin + (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) + #t) + #f))))) ;; open-run-close not needed for test-set-meta-info (tests:set-meta-info #f test-id run-id test-name itemdat minutes work-area) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) - (begin - (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") - (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) - (for-each - (lambda (p) - (let* ((parts (string-split p)) - (p-id (if (> (length parts) 0) - (string->number (car parts)) - #f))) - (if p-id - (begin - (debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id) - (system (conc "kill -9 " p-id)))))) - (car processes)) - (system (conc "kill -9 -" pid)))) + (process-signal pid signal/kill) + ;; (begin + ;; (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") + ;; (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) + ;; (for-each + ;; (lambda (p) + ;; (let* ((parts (string-split p)) + ;; (p-id (if (> (length parts) 0) + ;; (string->number (car parts)) + ;; #f))) + ;; (if p-id + ;; (begin + ;; (debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id) + ;; (system (conc "kill -9 " p-id)))))) + ;; (car processes)) + ;; (system (conc "kill -9 -" pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") (tests:test-set-status! test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (sqlite3:finalize! tdb) @@ -564,18 +573,19 @@ (list "MT_TEST_NAME" test-name) ;; (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) ;; (list "MT_TARGET" mt_target) )) - (let* ((useshell (config-lookup *configdat* "jobtools" "useshell")) - (launcher (config-lookup *configdat* "jobtools" "launcher")) - (runscript (config-lookup test-conf "setup" "runscript")) - (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big - (diskspace (config-lookup test-conf "requirements" "diskspace")) - (memory (config-lookup test-conf "requirements" "memory")) - (hosts (config-lookup *configdat* "jobtools" "workhosts")) + (let* ((useshell (config-lookup *configdat* "jobtools" "useshell")) + (launcher (config-lookup *configdat* "jobtools" "launcher")) + (runscript (config-lookup test-conf "setup" "runscript")) + (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big + (diskspace (config-lookup test-conf "requirements" "diskspace")) + (memory (config-lookup test-conf "requirements" "memory")) + (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) + (run-time-limit (configf:lookup test-conf "requirements" "runtimelim")) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to ;; allow running from dashboard. Extract the path ;; from the called megatest and convert dashboard ;; or dboard to megatest (local-megatest (let* ((lm (car (argv))) @@ -631,10 +641,11 @@ (list 'test-id test-id ) (list 'itemdat itemdat ) (list 'megatest remote-megatest) (list 'ezsteps ezsteps) (list 'target mt_target) + (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path))))))) ;; clean out step records from previous run if they exist Index: tests/fullrun/tests/priority_2/testconfig ================================================================== --- tests/fullrun/tests/priority_2/testconfig +++ tests/fullrun/tests/priority_2/testconfig @@ -1,10 +1,12 @@ [setup] runscript main.sh [requirements] priority 2 +# runtimelim 1d 1h 1m 10s +runtimelim 10s [test_meta] author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS