@@ -33,71 +33,73 @@ (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (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 #!key (remote #f)) - (let* ((mconfig (if *configdat* - *configdat* - (if (launch:setup-for-run) - *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)) - (runname (or (args:get-arg "-runname") - (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 - (for-each (lambda (keyval) - (setenv (car keyval)(cadr keyval))) - keyvals) - ;; Set up various and sundry known vars here - (setenv "MT_RUN_AREA_HOME" toppath) - (setenv "MT_RUNNAME" runname) - (setenv "MT_TARGET" target) - (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)) - (set! envdat (append - envdat - (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))) - (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))) - ;; Now have runconfigs data loaded, set environment vars - (for-each (lambda (section) - (for-each (lambda (varval) - (set! envdat (append envdat (list varval))) - (safe-setenv (car varval)(cadr varval))) - (configf:get-section runconfig section))) - (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 #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) - (let* ((target (or (common:args-get-target) +;;;;;; ;; 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* +;;;;;; (if (launch:setup-for-run) +;;;;;; *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)) +;;;;;; (runname (or (args:get-arg "-runname") +;;;;;; (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 +;;;;;; (for-each (lambda (keyval) +;;;;;; (setenv (car keyval)(cadr keyval))) +;;;;;; keyvals) +;;;;;; ;; Set up various and sundry known vars here +;;;;;; (setenv "MT_RUN_AREA_HOME" toppath) +;;;;;; (setenv "MT_RUNNAME" runname) +;;;;;; (setenv "MT_TARGET" target) +;;;;;; (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)) +;;;;;; (set! envdat (append +;;;;;; envdat +;;;;;; (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))) +;;;;;; (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))) +;;;;;; ;; Now have runconfigs data loaded, set environment vars +;;;;;; (for-each (lambda (section) +;;;;;; (for-each (lambda (varval) +;;;;;; (set! envdat (append envdat (list varval))) +;;;;;; (safe-setenv (car varval)(cadr varval))) +;;;;;; (configf:get-section runconfig section))) +;;;;;; (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)) + (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)) - (link-tree (configf:lookup *configdat* "setup" "linktree"))) + (link-tree (configf:lookup configdat "setup" "linktree"))) ;; get the info from the db and put it in the cache (if link-tree (setenv "MT_LINKTREE" link-tree) (debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) @@ -113,11 +115,11 @@ vals (lambda (key val) (debug:print 2 "setenv " key " " val) (safe-setenv key val))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) - (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) + (alist->env-vars (hash-table-ref/default configdat "env-override" '())) ;; 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))) @@ -157,20 +159,21 @@ (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) -(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) +(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs area-dat) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) (if (runs:lownoise "waiting on tasks" 60) (debug:print-info 2 "waiting for tasks to complete, sleeping briefly ...")) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((num-running (rmt:get-count-tests-running run-id)) + (let* ((configdat (megatest:area-configdat area-dat)) + (num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) - (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) + (job-group-limit (let ((jobg-count (config-lookup configdat "jobgroups" jobgroup))) (if (string? jobg-count) (string->number jobg-count) jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) @@ -202,16 +205,18 @@ ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; -(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names - (let* ((keys (keys:config-get-fields *configdat*)) +(define (runs:run-tests target runname test-patts user flags area-dat #!key (run-count 3)) ;; test-names + (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (keys (keys:config-get-fields configdat)) (keyvals (keys:target->keyval keys target)) - (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) + (run-id (rmt:register-run keyvals runname "new" "n/a" user area-dat)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause - (runconfigf (conc *toppath* "/runconfigs.config")) + (runconfigf (conc toppath "/runconfigs.config")) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; (tests:filter-test-names all-test-names test-patts)) @@ -246,11 +251,11 @@ ;; 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*)) + (debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat)) (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 @@ -268,11 +273,11 @@ ;; Now convert FAIL and anything in allow-auto-rerun to NOT_STARTED ;; (for-each (lambda (state) (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state)) - (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) + (string-split (or (configf:lookup configdat "setup" "allow-auto-rerun") ""))))) ;; Ensure all tests are registered in the test_meta table (runs:update-all-test_meta #f) ;; now add non-directly referenced dependencies (i.e. waiton) @@ -366,11 +371,11 @@ (if (not (null? required-tests)) (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) - (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) + (let ((reglen (configf:lookup configdat "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (run-queue-retries 5) (th1 (make-thread (lambda () (handle-exceptions @@ -379,12 +384,12 @@ (print-call-chain (current-error-port)) (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) (if (> run-queue-retries 0) (begin (set! run-queue-retries (- run-queue-retries 1)) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry area-dat)))) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry area-dat))) "runs:run-tests-queue")) (th2 (make-thread (lambda () ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) @@ -405,11 +410,11 @@ (begin (if (not (hash-table-ref/default flags "-preclean" #f)) (hash-table-set! flags "-preclean" #t)) (if (not (hash-table-ref/default flags "-rerun" #f)) (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) - (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) + (runs:run-tests target runname test-patts user flags area-dat run-count: (- run-count 1))))) (debug:print-info 0 "No tests to run"))) (debug:print-info 4 "All done by here") (rmt:tasks-set-state-given-param-key task-key "done") ;; (sqlite3:finalize! tasks-db) )) @@ -637,12 +642,14 @@ t) (else (conc t)))) inlst))) -(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap) - (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running +(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap area-dat) + (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) @@ -651,12 +658,12 @@ (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (loop-list (list hed tal reg reruns)) ;; configure the load runner (numcpus (common:get-num-cpus)) - (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3"))) - (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) + (maxload (string->number (or (configf:lookup configdat "jobtools" "maxload") "3"))) + (waitdelay (string->number (or (configf:lookup configdat "jobtools" "waitdelay") "60")))) (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) @@ -751,11 +758,11 @@ ;; we are going to reset all the counters for test retries by setting a new hash table ;; this means they will increment only when nothing can be run (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 + (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) (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*) @@ -885,27 +892,29 @@ ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table)) ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) +(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry area-dat) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (cdb:remote-run db:find-and-mark-incomplete #f) - (let ((run-info (rmt:get-run-info run-id)) + (let ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (run-info (rmt:get-run-info run-id area-dat)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) (num-retries 0) - (max-retries (config-lookup *configdat* "setup" "maxretries")) - (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) + (max-retries (config-lookup configdat "setup" "maxretries")) + (max-concurrent-jobs (let ((mcj (config-lookup configdat "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) (string->number mcj) 1))) ;; length of the register queue ahead (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle @@ -954,11 +963,11 @@ (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) (tfullname (db:test-make-full-name test-name item-path)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) - (num-running (rmt:get-count-tests-running-for-run-id run-id))) + (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:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood @@ -972,11 +981,11 @@ ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) (begin - (rmt:general-call 'register-test run-id run-id test-name "") + (rmt:general-call 'register-test run-id run-id test-name "" area-dat) (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) @@ -1123,29 +1132,29 @@ (else (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) - (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) + (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id area-dat)) (prev-num-running 0)) ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") - (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) + (equal? (configf:lookup configdat "setup" "run-wait") "yes")) (> num-running 0)) (begin ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) (if (> (current-seconds)(+ last-time-incomplete 900)) (begin (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) (set! last-time-incomplete (current-seconds)) - (rmt:find-and-mark-incomplete run-id #f))) + (rmt:find-and-mark-incomplete run-id #f area-dat))) (if (not (eq? num-running prev-num-running)) (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds))))) (thread-sleep! 5) ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) - (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) + (wait-loop (rmt:get-count-tests-running-for-run-id run-id area-dat) num-running)))) ;; LET* ((test-record ;; we get here on "drop through". All done! (debug:print-info 1 "All tests launched"))) (define (runs:calc-fails prereqs-not-met) @@ -1203,11 +1212,11 @@ (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 ... (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"))) + (incomplete-timeout (string->number (or (configf:lookup configdat "setup" "incomplete-timeout") "x"))) (item-path "") (db #f) (full-test-name #f)) ;; setting itemdat to a list if it is #f @@ -1238,12 +1247,12 @@ (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (test-id (rmt:get-test-id run-id test-name item-path)) - (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) + (test-id (rmt:get-test-id run-id test-name item-path area-dat)) + (testdat (if test-id (rmt:get-test-info-by-id run-id test-id area-dat) #f))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) @@ -1250,18 +1259,18 @@ ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) + (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path area-dat))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:general-call 'register-test run-id run-id test-name item-path) - (set! test-id (rmt:get-test-id run-id test-name item-path)))) + (rmt:general-call 'register-test run-id run-id test-name item-path area-dat) + (set! test-id (rmt:get-test-id run-id test-name item-path area-dat)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (set! testdat (rmt:get-test-info-by-id run-id test-id)) + (set! testdat (rmt:get-test-info-by-id run-id test-id area-dat)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) @@ -1329,11 +1338,11 @@ ;; 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")) ;; run-ids = #f means *all* runs - (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) + (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f area-dat))) (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")) @@ -1413,15 +1422,15 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) +(define (runs:operate-on action target runnamepatt testpatt area-dat #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) (common:clear-caches) ;; clear all caches (let* ((db #f) (tdbdat (tasks:open-db)) - (keys (rmt:get-keys)) + (keys (rmt:get-keys area-dat)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) @@ -1499,11 +1508,11 @@ (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) - (new-test-dat (rmt:get-test-info-by-id run-id test-id))) + (new-test-dat (rmt:get-test-info-by-id run-id test-id area-dat))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) @@ -1514,11 +1523,11 @@ (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree (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)))) + (> (rmt:test-toplevel-num-items run-id test-name area-dat) 0)))) (case action ((remove-runs) ;; if the test is a toplevel-with-children issue an error and do not remove (if toplevel-with-children (begin @@ -1586,12 +1595,12 @@ (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") - (rmt:delete-run run-id) - (rmt:delete-old-deleted-test-records) + (rmt:delete-run run-id area-dat) + (rmt:delete-old-deleted-test-records area-dat) ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) @@ -1645,21 +1654,24 @@ )) ;; Only delete the records *after* removing the directory. If things fail we have a record (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) - (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))))) + (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test) area-dat))))) ;;====================================================================== ;; Routines for manipulating runs ;;====================================================================== ;; Since many calls to a run require pretty much the same setup ;; this wrapper is used to reduce the replication of code -(define (general-run-call switchname action-desc proc) - (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))) - (target (common:args-get-target))) +(define (general-run-call switchname action-desc proc area-dat) + (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))) + (target (common:args-get-target)) + (toppath (megatest:area-path area-dat)) + (configdat (megatest:area-configdat area-dat)) + (configinfo (megatest:area-configinfo area-dat))) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) @@ -1666,21 +1678,21 @@ (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") (exit 3)) (else (let (;; (db #f) (keys #f)) - (if (launch:setup-for-run) - (launch:cache-config) + (if (launch:setup-for-run area-dat) + (launch:cache-config area-dat) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; (if (args:get-arg "-server") ;; (cdb:remote-run server:start db (args:get-arg "-server"))) - (set! keys (keys:config-get-fields *configdat*)) + (set! keys (keys:config-get-fields configdat)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") - (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL + (let* ((runconfigf (conc toppath "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #t environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) (begin @@ -1688,11 +1700,11 @@ ;; (if db (sqlite3:finalize! db)) (exit 1) ))) (if (args:get-arg "-target") (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) - (if (not (car *configinfo*)) + (if (not (car configinfo)) (begin (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc @@ -1715,34 +1727,34 @@ (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) - (rmt:lock/unlock-run run-id lock unlock user) + (rmt:lock/unlock-run run-id lock unlock user area-dat) (debug:print-info 0 "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test -(define (runs:update-test_meta test-name test-conf) - (let ((currrecord (rmt:testmeta-get-record test-name))) +(define (runs:update-test_meta test-name test-conf area-dat) + (let ((currrecord (rmt:testmeta-get-record test-name area-dat))) (if (not currrecord) (begin (set! currrecord (make-vector 11 #f)) - (rmt:testmeta-add-record test-name))) + (rmt:testmeta-add-record test-name area-dat))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) - (rmt:testmeta-update-field test-name fld val))))) + (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))) @@ -1753,19 +1765,19 @@ (hash-table-keys test-names)))) ;; This could probably be refactored into one complex query ... ;; NOT PORTED - DO NOT USE YET ;; -(define (runs:rollup-run keys runname user keyvals) +(define (runs:rollup-run keys runname user keyvals area-dat) (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) ;; register run operates on the main db - (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) - (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) - (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) + (new-run-id (rmt:register-run keyvals runname "new" "n/a" user area-dat)) + (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%" area-dat)) + (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '() area-dat)) (curr-tests-hash (make-hash-table))) - (rmt:update-run-event_time new-run-id) + (rmt:update-run-event_time new-run-id area-dat) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) @@ -1779,11 +1791,11 @@ (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) + (test-steps (rmt:get-steps-for-test (db:test-get-id testdat) area-dat)) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "