@@ -36,15 +36,17 @@ (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) ;;;;;; ;; This is the *new* methodology. One record to inform them and in the chaos, organise them. ;;;;;; ;; ;;;;;; (define (runs:create-run-record area-dat) ;; #!key (remote #f)) -;;;;;; (let* ((remote (megatest:area-remote area-dat)) -;;;;;; (mconfig (if *configdat* -;;;;;; *configdat* +;;;;;; (let* ((remote (megatest:area-remote area-dat)) +;;;;;; (configdat (megatest:area-configdat area-dat)) +;;;;;; (toppath (megatest:area-path area-dat))) +;;;;;; (mconfig (if configdat +;;;;;; configdat ;;;;;; (if (launch:setup-for-run) -;;;;;; *configdat* +;;;;;; configdat ;;;;;; (begin ;;;;;; (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") ;;;;;; (exit 1))))) ;;;;;; (runrec (runs:runrec-make-record)) ;;;;;; (target (common:args-get-target)) @@ -52,11 +54,10 @@ ;;;;;; (args:get-arg ":runname"))) ;;;;;; (testpatt (or (args:get-arg "-testpatt") ;;;;;; (args:get-arg "-runtests"))) ;;;;;; (keys (keys:config-get-fields mconfig)) ;;;;;; (keyvals (keys:target->keyval keys target)) -;;;;;; (toppath *toppath*) ;;;;;; (envdat keyvals) ;; initial values start with keyvals ;;;;;; (runconfig #f) ;;;;;; (transport (or (args:get-arg "-transport") 'http)) ;;;;;; (run-id #f)) ;;;;;; ;; Set all the environment vars we know so far, start with keys @@ -73,11 +74,11 @@ ;;;;;; (list (list "MT_RUN_AREA_HOME" toppath) ;;;;;; (list "MT_RUNNAME" runname) ;;;;;; (list "MT_TARGET" target)))) ;;;;;; ;; Now can read the runconfigs file ;;;;;; ;; -;;;;;; (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) +;;;;;; (set! runconfig (read-config (conc toppath "/runconfigs.config") #f #t sections: (list "default" target))) ;;;;;; (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) ;;;;;; (begin ;;;;;; (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) ;;;;;; (if db (sqlite3:finalize! db)) ;;;;;; (exit 1))) @@ -90,10 +91,11 @@ ;;;;;; (list "default" target)) ;;;;;; (vector target runname testpatt keys keyvals envdat mconfig runconfig (common:get-remote remote run-id) transport db toppath run-id))) (define (runs:set-megatest-env-vars run-id area-dat #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) (target (or (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) @@ -121,11 +123,11 @@ ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) (debug:print 0 "ERROR: no value for runname for id " run-id))) - (setenv "MT_RUN_AREA_HOME" *toppath*))) + (setenv "MT_RUN_AREA_HOME" toppath))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) @@ -222,11 +224,11 @@ (test-names #f) ;; (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) (tdbdat (tasks:open-db))) - (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10)) (set-signal-handler! signal/int (lambda (signum) (signal-mask! signum) (print "Received signal " signum ", cleaning up before exit. Please wait...") @@ -236,26 +238,26 @@ (exit))) ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key task-key "running") - (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process + (runs:set-megatest-env-vars run-id area-dat inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; Now generate all the tests lists - (set! all-tests-registry (tests:get-all)) + (set! all-tests-registry (tests:get-all area-dat)) (set! all-test-names (hash-table-keys all-tests-registry)) (set! test-names (tests:filter-test-names all-test-names test-patts)) (set! required-tests (lset-intersection equal? (string-split test-patts ",") test-names)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) - ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) - (debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat)) + ;; (set! test-names (delete-duplicates (tests:get-valid-tests toppath test-patts))) + (debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat area-dat)) (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified @@ -288,11 +290,11 @@ ;; ;;====================================================================== (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. + (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. (setenv "MT_TEST_NAME" hed) ;; (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test @@ -515,11 +517,11 @@ (null? non-completed))) (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (if (null? items-list) (let ((test-id (rmt:get-test-id run-id test-name ""))) @@ -760,11 +762,11 @@ (set! *max-tries-hash* (make-hash-table)) ;; well, first lets see if cpu load throttling is enabled. If so wait around until the ;; average cpu load is under the threshold before continuing (if (configf:lookup configdat "jobtools" "maxload") ;; only gate if maxload is specified (common:wait-for-cpuload maxload numcpus waitdelay)) - (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) + (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry area-dat) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) @@ -967,11 +969,11 @@ (regfull (>= (length reg) reglen)) (num-running (rmt:get-count-tests-running-for-run-id run-id area-dat))) ;; every couple minutes verify the server is there for this run (if (and (common:low-noise-print 60 "try start server" run-id) - (tasks:need-server run-id)) + (tasks:need-server run-id area-dat)) (tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood (if (> num-running 0) (set! last-time-some-running (current-seconds))) @@ -1202,17 +1204,18 @@ (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step -(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) +(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry area-dat) ;; All these vars might be referenced by the testconfig file reader - (let* ((test-name (tests:testqueue-get-testname test-record)) + (let* ((toppath (megatest:area-path area-dat)) + (test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) - (test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... + (test-path (hash-table-ref all-tests-registry test-name)) (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (incomplete-timeout (string->number (or (configf:lookup configdat "setup" "incomplete-timeout") "x"))) (item-path "") @@ -1230,12 +1233,12 @@ ) (debug:print 2 "Attempting to launch test " full-test-name) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_ITEMPATH" item-path) (setenv "MT_RUNNAME" runname) - (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process - (change-directory *toppath*) + (runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process + (change-directory toppath) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; ;; There is now a single call to runs:update-all-test_meta and this @@ -1279,11 +1282,11 @@ (set! test-id (db:test-get-id testdat)) (if (file-exists? test-path) (change-directory test-path) (begin (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") - (change-directory *toppath*))) + (change-directory toppath))) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) @@ -1463,18 +1466,18 @@ (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((remove-runs) - (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + (if (tasks:need-server run-id area-dat)(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) (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 "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)) + (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) @@ -1755,11 +1758,11 @@ (rmt:testmeta-update-field test-name fld val area-dat))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) - (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) + (let ((test-names (tests:get-all area-dat))) ;; (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-conf (mt:lazy-read-test-config test-name))) (if test-conf (runs:update-test_meta test-name test-conf)))) (hash-table-keys test-names))))