Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -99,10 +99,13 @@ ;;====================================================================== ;; Misc utils ;;====================================================================== +(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) 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 "\"") 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/fdktestqa/testqa/tests/bigrun/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/testconfig +++ tests/fdktestqa/testqa/tests/bigrun/testconfig @@ -8,10 +8,11 @@ priority 0 # Iteration for your tests are controlled by the items section [items] NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500))(loop (+ a 1)(cons a res)) res)) <)) " ")} +# NUMBER #{shell xterm} # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt