Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -99,10 +99,35 @@ ;;====================================================================== ;; 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) (let ((res #f)) (for-each (lambda (arg) @@ -170,10 +195,23 @@ (loop (car tala) (cdr tala) (car talb) (cdr talb))) #f))))) + +;; Needed for long lists to be sorted where (apply max ... ) dies +;; +(define (common:max inlst) + (let loop ((max-val (car inlst)) + (hed (car inlst)) + (tal (cdr inlst))) + (if (not (null? tal)) + (loop (max hed max-val) + (car tal) + (cdr tal)) + (max hed max-val)))) + ;;====================================================================== ;; Munge data into nice forms ;;====================================================================== Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -269,11 +269,11 @@ (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) '() (map car sectdat)))) -(define (configf:get-section cfdat section) +(define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) (define (setup) (let* ((configf (find-config)) (config (if configf (read-config configf #f #t) #f))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -875,15 +875,21 @@ ;; ;; General info about the run(s) and megatest area (define (dashboard:summary) (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))) (iup:vbox - (iup:frame - #:title "General Info" - (iup:hbox - (dcommon:general-info) - (dcommon:keys-matrix rawconfig))) + (iup:split + ;; #:value 500 + (iup:frame + #:title "General Info" + (iup:hbox + (dcommon:keys-matrix rawconfig) + (dcommon:general-info) + )) + (iup:frame + #:title "Server" + (dcommon:servers-table))) (iup:frame #:title "Megatest config settings" (iup:hbox (dcommon:section-matrix rawconfig "setup" "Varname" "Value") (iup:vbox @@ -912,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)))) @@ -932,17 +939,23 @@ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) (tests-dat (let ((tdat (mt:get-tests-for-run run-id "%" '() '() qryvals: "id,testname,item_path,state,status"))) ;; get 'em all (sort tdat (lambda (a b) - (string<= (vector-ref a 2)(vector-ref b 2)))))) + (let* ((aval (vector-ref a 2)) + (bval (vector-ref b 2)) + (anum (string->number aval)) + (bnum (string->number bval))) + (if (and anum bnum) + (< anum bnum) + (string<= aval bval))))))) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (apply max (map cadr col-indices)))) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) (max-visible (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window (numrows 1) (numcols 1) (changed #f) (runs-hash (let ((ht (make-hash-table))) @@ -1272,20 +1285,28 @@ (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and (> modtime last-db-update-time) (> (current-seconds)(+ last-db-update-time 1))))) +(define *monitor-db-path* (conc *toppath* "/monitor.db")) +(define *last-monitor-update-time* 0) + (define (dashboard:run-update x) (let* ((modtime (file-modification-time *db-file-path*)) + (monitor-modtime (file-modification-time *monitor-db-path*)) (run-update-time (current-seconds)) (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) - (if recalc + (if (and (eq? *current-tab-number* 0) + (> monitor-modtime *last-monitor-update-time*)) (begin + (set! *last-monitor-update-time* monitor-modtime) + (if dashboard:update-servers-table (dashboard:update-servers-table)))) + (if recalc + (begin (case *current-tab-number* ((0) - ;; (thread-sleep! 0.25) ;; - (dashboard:update-summary-tab)) + (if dashboard:update-summary-tab (dashboard:update-summary-tab))) ((1) ;; The runs table is active (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* (hash-table-ref/default *searchpatts* "test-name" "%/%") ;; (hash-table-ref/default *searchpatts* "item-name" "%") (let ((res '())) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -908,20 +908,20 @@ (debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} -(define (db:get-tests-for-runs-mindata db run-ids testpatt states status) - (db:get-tests-for-runs db run-ids testpatt states status qryvals: "id,run_id,testname,state,status,event_time,item_path")) +(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) + (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) ;; NB // This is get tests for "runs" (note the plural!!) ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match -;; run-ids is a list of run-ids or a single number +;; run-ids is a list of run-ids or a single number or #f for all runs (define (db:get-tests-for-runs db run-ids testpatt states statuses #!key (not-in #t) (sort-by #f) (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) @@ -941,15 +941,15 @@ " IN ('" (string-intersperse statuses "','") "')"))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvals - " FROM tests WHERE state != 'DELETED' AND " + " FROM tests WHERE state != 'DELETED' " (if run-ids (if (list? run-ids) - (conc " run_id in (" (string-intersperse (map conc run-ids) ",") ") ") - (conc "run_id=" run-ids " ")) + (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ") + (conc "AND run_id=" run-ids " ")) " ") ;; #f => run-ids don't filter on run-ids (if states-qry (conc " AND " states-qry) "") (if statuses-qry (conc " AND " statuses-qry) "") (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by @@ -1053,11 +1053,11 @@ ;; speed up for common cases with a little logic (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) - (sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id)) + (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id)) ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (else (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) @@ -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: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -26,10 +26,11 @@ (include "db_records.scm") (include "key_records.scm") ;; yes, this is non-ideal (define dashboard:update-summary-tab #f) +(define dashboard:update-servers-table #f) ;;====================================================================== ;; C O M M O N D A T A S T R U C T U R E ;;====================================================================== ;; @@ -145,11 +146,11 @@ ;; Now can calculate the run-ids (run-hash (hash-table-ref/default data get-runs-sig #f)) (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) - (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses)) + (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses #f)) (runs-hash (hash-table-ref/default data get-runs-sig #f)) (header (hash-table-ref/default runs-hash "header" #f)) (run-ids (sort (filter number? (hash-table-keys runs-hash)) (lambda (a b) (let* ((record-a (hash-table-ref runs-hash a)) @@ -305,11 +306,12 @@ #:numlin (length key-vals) #:numcol-visible 1 #:numlin-visible (length key-vals) #:click-cb (lambda (obj lin col status) (print "obj: " obj " lin: " lin " col: " col " status: " status))))) - (iup:attribute-set! keys-matrix "0:0" "Run Keys") + ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") + (iup:attribute-set! keys-matrix "WIDTH0" 0) (iup:attribute-set! keys-matrix "0:1" "Key Name") ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") ;; fill in keys (for-each (lambda (var) @@ -316,10 +318,11 @@ ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) key-vals) + (iup:attribute-set! keys-matrix "WIDTHDEF" "40") keys-matrix)) ;; Section to table (define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f)) (let* ((curr-row-num 1) @@ -364,15 +367,16 @@ (iup:attribute-set! general-matrix "0:1" "About this Megatest area") ;; User (this is not always obvious - it is common to run as a different user (iup:attribute-set! general-matrix "1:0" "User") (iup:attribute-set! general-matrix "1:1" (current-user-name)) ;; Megatest area - (iup:attribute-set! general-matrix "2:0" "Megatest area") + (iup:attribute-set! general-matrix "2:0" "Area") (iup:attribute-set! general-matrix "2:1" *toppath*) ;; Megatest version - (iup:attribute-set! general-matrix "3:0" "Megatest version") + (iup:attribute-set! general-matrix "3:0" "Version") (iup:attribute-set! general-matrix "3:1" megatest-version) + general-matrix)) (define (dcommon:run-stats) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) @@ -433,10 +437,93 @@ (iup:attribute-set! stats-matrix "WIDTHDEF" "40") (iup:vbox (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) +(define (dcommon:servers-table) + (let* ((colnum 0) + (rownum 0) + (servers-matrix (iup:matrix #:expand "YES" + #:numcol 7 + #:numcol-visible 7 + #:numlin-visible 3 + )) + (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "State" "Transport")) + (updater (lambda () + (let ((servers (open-run-close tasks:get-all-servers tasks:open-db))) + (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) + ;; (set! colnum 0) + ;; (for-each (lambda (colname) + ;; ;; (print "colnum: " colnum " colname: " colname) + ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + ;; (set! colnum (+ 1 colnum))) + ;; colnames) + (set! rownum 1) + (for-each + (lambda (server) + (set! colnum 0) + (let* ((vals (list (vector-ref server 0) ;; Id + (vector-ref server 9) ;; MT-Ver + (vector-ref server 1) ;; Pid + (vector-ref server 2) ;; Hostname + (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port + (vector-ref server 5) ;; Pubport + ;; (vector-ref server 10) ;; Last beat + ;; (vector-ref server 6) ;; Start time + ;; (vector-ref server 7) ;; Priority + ;; (vector-ref server 8) ;; State + (if (< (vector-ref server 10) 20) ;; Status (Please redo this properly!) + "alive" + "dead") + (vector-ref server 11) ;; Transport + ))) + (for-each (lambda (val) + ;; (print "rownum: " rownum " colnum: " colnum " val: " val) + (iup:attribute-set! servers-matrix (conc rownum ":" colnum) val) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) + (set! colnum (+ 1 colnum))) + vals) + (set! rownum (+ rownum 1))) + (iup:attribute-set! servers-matrix "REDRAW" "ALL")) + servers))))) + (set! colnum 0) + (for-each (lambda (colname) + (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) + (set! colnum (+ colnum 1))) + colnames) + (set! dashboard:update-servers-table updater) + ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40") + (iup:hbox + (iup:vbox + (iup:button "Start" + ;; #:size "50x" + #:expand "YES" + #:action (lambda (obj) + (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + "megatest -server - &"))) + ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd)))) + (iup:button "Stop" + #:expand "YES" + ;; #:size "50x" + #:action (lambda (obj) + (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + "megatest -stop-server 0 &"))) + ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd)))) + (iup:button "Restart" + #:expand "YES" + ;; #:size "50x" + #:action (lambda (obj) + (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + "megatest -stop-server 0;megatest -server - &"))) + ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd))))) + servers-matrix + ))) + ;; The main menu (define (dcommon:main-menu) (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options (iup:menu-item "Open" action: (lambda (obj) Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -24,16 +24,21 @@ (define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) ;; ((if get-label cadr car) (case (string->symbol state) ((COMPLETED) - (if (equal? status "PASS") - '("70 249 73" "PASS") - (if (or (equal? status "WARN") - (equal? status "WAIVED")) - (list "255 172 13" status) - (list "223 33 49" status)))) ;; greenish orangeish redish + (case (string->symbol status) + ((PASS) (list "70 249 73" status)) + ((WARN WAIVED) (list "255 172 13" status)) + ((SKIP) (list "230 230 0" status)) + (else (list "223 33 49" status)))) + ;; (if (equal? status "PASS") + ;; '("70 249 73" "PASS") + ;; (if (or (equal? status "WARN") + ;; (equal? status "WAIVED")) + ;; (list "255 172 13" status) + ;; (list "223 33 49" status)))) ;; greenish orangeish redish ((LAUNCHED) (list "101 123 142" state)) ((CHECK) (list "255 100 50" state)) ((REMOTEHOSTSTART) (list "50 130 195" state)) ((RUNNING) (list "9 131 232" state)) ((KILLREQ) (list "39 82 206" state)) 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: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.5507) +(define megatest-version 1.5508) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -344,23 +344,23 @@ (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (setup-for-run))) (if tl (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db)) - (fmtstr "~5a~8a~8a~20a~20a~10a~10a~10a~10a~10a\n") + (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) (killinfo (args:get-arg "-stop-server")) (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f)) (sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))) - (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface" "OutPort" "InPort" "LastBeat" "State" "Transport") - (format #t fmtstr "==" "=====" "===" "====" "=========" "=======" "======" "========" "=====" "=========") + (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport") + (format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========") (for-each (lambda (server) (let* ((id (vector-ref server 0)) (pid (vector-ref server 1)) (hostname (vector-ref server 2)) - (interface (vector-ref server 3)) + (interface (vector-ref server 3)) (pullport (vector-ref server 4)) (pubport (vector-ref server 5)) (start-time (vector-ref server 6)) (priority (vector-ref server 7)) (state (vector-ref server 8)) @@ -375,11 +375,11 @@ (if (equal? state "dead") (if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day. (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid action: 'delete)) (if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid))) - (format #t fmtstr id mt-ver pid hostname interface pullport pubport last-update + (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update (if status "alive" "dead") transport) (if (or (equal? id sid) (equal? sid 0)) ;; kill all/any (begin (debug:print-info 0 "Attempting to stop server with pid " pid) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -115,10 +115,11 @@ (hash-table-for-each vals (lambda (key val) (debug:print 2 "setenv " key " " val) (setenv key val))) + (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*))) @@ -181,13 +182,11 @@ (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) (test-records (make-hash-table)) (all-test-names (tests:get-valid-tests *toppath* "%"))) ;; we need a list of all valid tests to check waiton names - (set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process - (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in @@ -212,10 +211,11 @@ ;; refactoring this block into tests:get-full-data ;;====================================================================== (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc + (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. (let* ((config (tests:get-testconfig hed 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print 0 "ERROR: non-existent required test \"" hed "\"") @@ -847,15 +847,34 @@ "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override")) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. ;; This would be a great place to do the process-fork - (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) - (begin - (print "ERROR: Failed to launch the test. Exiting as soon as possible") - (set! *globalexitstatus* 1) ;; - (process-signal (current-process-id) signal/kill)))))) + ;; + (let ((skip-test #f) + (skip-check (configf:get-section test-conf "skip"))) + (cond + ;; Have to check for skip conditions. This one skips if there are same-named tests + ;; currently running + ((and skip-check + (configf:lookup test-conf "skip" "prevrunning")) + (let ((running-tests (cdb:remote-run db:get-tests-for-runs-mindata #f #f full-test-name '("RUNNING") '() #f))) + (if (not (null? running-tests)) ;; have to skip + (set! skip-test "Skipping due to previous tests running")))) + ((and skip-check + (configf:lookup test-conf "skip" "fileexists")) + (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) + (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) + (if skip-test + (begin + (cdb:remote-run db:test-set-state-status-by-id #f test-id "COMPLETED" "SKIP" skip-test) + (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) + (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) + (begin + (print "ERROR: Failed to launch the test. Exiting as soon as possible") + (set! *globalexitstatus* 1) ;; + (process-signal (current-process-id) signal/kill)))))))) ((KILLED) (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")) ((LAUNCHED REMOTEHOSTSTART RUNNING) (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) (db:test-get-run_duration testdat))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -97,11 +97,14 @@ (debug:print-info 11 "tasks:server-register " pid " " interface " " port " " priority " " state) (sqlite3:execute mdb "INSERT OR REPLACE INTO servers (pid,hostname,port,pubport,start_time,priority,state,mt_version,heartbeat,interface,transport) VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?, strftime('%s','now'),?,?);" - pid (get-host-name) port pubport priority (conc state) megatest-version interface (conc transport)) + pid (get-host-name) port pubport priority (conc state) + (common:version-signature) + interface + (conc transport)) (vector (tasks:server-get-server-id mdb (get-host-name) interface port pid) interface port pubport @@ -206,11 +209,11 @@ ) mdb "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers WHERE strftime('%s','now')-heartbeat < 10 - AND mt_version=? ORDER BY start_time DESC LIMIT 1;" megatest-version) + AND mt_version=? ORDER BY start_time DESC LIMIT 1;" (common:version-signature)) ;; for now we are keeping only one server registered in the db, return #f or first server found (if (null? res) #f (car res)))) ;; BUG: This logic is probably needed unless methodology changes completely... ;; Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -26,10 +26,14 @@ stopserver : cd ..;make && make install cd fullrun;$(MEGATEST) -stop-server 0 +repl : + cd ..;make && make install + cd fullrun;$(MEGATEST) -repl + test0 : cleanprep cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) test1 : cleanprep rm -f simplerun/megatest.db @@ -57,12 +61,12 @@ # NOTE: Only one instance can be a server test5 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & + cd fullrun;sleep 5;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & + cd fullrun;sleep 8;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & # cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & # cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & a # MUST ADD THIS BACK IN ASAP!!!! # cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE 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 Index: tests/fullrun/tests/priority_5/testconfig ================================================================== --- tests/fullrun/tests/priority_5/testconfig +++ tests/fullrun/tests/priority_5/testconfig @@ -2,10 +2,13 @@ runscript main.sh [requirements] priority 5 +[skip] +prevrunning #t + [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