Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -772,12 +772,12 @@ " run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;;(debug:print 0 "QRY: " qry) (sqlite3:execute db qry run-id newstate newstatus testname testname))) testnames)) -(define (db:delete-tests-in-state db run-id state) - (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id)) +(define (cdb:delete-tests-in-state zmqsocket run-id state) + (cdb:client-call zmqsocket 'delete-tests-in-state #t run-id state)) ;; 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) @@ -1216,10 +1216,11 @@ ELSE status END WHERE id=?;") '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") + '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") )) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail db:roll-up-pass-fail-counts)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -104,17 +104,17 @@ (exit 1))) ;; Can setup as client for server mode now (server:client-setup) (change-directory *toppath*) - (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id) ;; these may be needed by the launching process (change-directory work-area) (open-run-close set-run-config-vars #f run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (open-run-close set-megatest-env-vars #f run-id) + (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") (open-run-close test-set-meta-info #f test-id run-id test-name itemdat 0) (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (if (args:get-arg "-xterm") @@ -437,11 +437,11 @@ (if (not (hash-table-ref/default *toptest-paths* testname #f)) (let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? - (cdb:test-set-rundir! *runremote* run-id testname item-path lnkpath) ;; toptest-path) + (cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) (create-directory toptest-path #t) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -71,44 +71,51 @@ ;; Awful. Please FIXME (define *env-vars-by-run-id* (make-hash-table)) (define *current-run-name* #f) -(define (set-megatest-env-vars db run-id) - (let ((keys (db:get-keys db)) +(define (db:get-run-key-val db run-id key) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") + run-id) + res)) + +(define (db:get-run-name-from-id db run-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (runname) + (set! res runname)) + db + "SELECT runname FROM runs WHERE id=?;" + run-id) + res)) + +(define (set-megatest-env-vars run-id) + (let ((keys (cdb:remote-run db:get-keys #f)) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) ;; get the info from the db and put it in the cache (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each (lambda (key) - (sqlite3:for-each-row - (lambda (val) - (hash-table-set! vals key val)) - db - (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") - run-id)) + (hash-table-set! vals key (cdb:remote-run db:get-run-key-val #f run-id key))) keys))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) (debug:print 2 "setenv " (key:get-fieldname key) " " val) (setenv (key:get-fieldname key) val))) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (if (not *current-run-name*) - (sqlite3:for-each-row - (lambda (runname) - (set! *current-run-name* runname)) - - db - "SELECT runname FROM runs WHERE id=?;" - run-id)) - (setenv "MT_RUNNAME" *current-run-name*) + (setenv "MT_RUNNAME" (cdb:remote-run db:get-run-name-from-id #f run-id)) (setenv "MT_RUN_AREA_HOME" *toppath*) )) (define (set-item-env-vars itemdat) (for-each (lambda (item) @@ -115,15 +122,15 @@ (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) (define *last-num-running-tests* 0) -(define (runs:can-run-more-tests db test-record) +(define (runs:can-run-more-tests test-record) (let* ((tconfig (tests:testqueue-get-testconfig test-record)) (jobgroup (config-lookup tconfig "requirements" "jobgroup")) - (num-running (db:get-count-tests-running db)) - (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup)) + (num-running (cdb:remote-run db:get-count-tests-running #f)) + (num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup)) (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) (string->number mcj) #f))) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) @@ -189,22 +196,22 @@ ;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. ;; keyvals (define (runs:run-tests target runname test-patts user flags) (let* ((db #f) - (keys (open-run-close db:get-keys db)) + (keys (cdb:remote-run db:get-keys #f)) (keyvallst (keys:target->keyval keys target)) - (run-id (open-run-close runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) + (run-id (cdb:remote-run runs:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause ;; keepgoing is the defacto modality now, will add hit-n-run a bit later ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (test-names '()) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) (test-records (make-hash-table))) - (open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id) ;; these may be needed by the launching process (if (file-exists? runconfigf) (open-run-close setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) @@ -222,12 +229,12 @@ (begin ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. - (open-run-close db:delete-tests-in-state db run-id "NOT_STARTED") - (open-run-close db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED") + (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) ;; from here on out the db will be opened and closed on every call runs:run-tests-queue ;; (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) (if (not (null? test-names)) @@ -371,11 +378,11 @@ (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond ;; OUTER COND ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (let* ((run-limits-info (open-run-close runs:can-run-more-tests #f test-record)) ;; look at the test jobgroup and tot jobs running + (let* ((run-limits-info (open-run-close runs:can-run-more-tests test-record)) ;; 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)) @@ -474,11 +481,11 @@ (loop (car tal)(cdr tal) reruns)))) ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (open-run-close runs:can-run-more-tests #f test-record))) + (let ((can-run-more (runs:can-run-more-tests test-record))) (if can-run-more (let* ((prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print-info 8 "can-run-more: " can-run-more @@ -500,11 +507,11 @@ (and (eq? testmode 'toplevel) (null? non-completed))) (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (tests:testqueue-set-items! test-record items-list) (thread-sleep! *global-delta*) @@ -598,11 +605,11 @@ (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) (debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "/") "/" item-path)) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id) ;; 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? (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) @@ -611,12 +618,12 @@ (open-run-close runs:update-test_meta db test-name test-conf))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique - (test-id (open-run-close db:get-test-id db run-id test-name item-path)) - (testdat (open-run-close db:get-test-info-by-id db test-id))) + (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) + (testdat (cdb:remote-run db:get-test-info-by-id #f test-id))) (if (not testdat) (begin ;; 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)) Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -283,17 +283,17 @@ (number? test-id))) (test "Get rundir" #t (let ((rundir (db:test-get-rundir-from-test-id db test-id))) (print "Rundir" rundir) (string? rundir))) -(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db" (let ((tdb (db:open-test-db-by-test-id db test-id))) - (sqlite3#finalize! tdb) - (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db"))) -(test "Get steps for test" #t (> (length (db:get-steps-for-test db test-id)) 0)) +(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db" (let ((tdb (open-run-close db:open-test-db-by-test-id #f test-id))) + (sqlite3#finalize! tdb) + (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db"))) +(test "Get steps for test" #t (> (length (open-run-close db:get-steps-for-test test-id)) 0)) (test "Get nice table for steps" "2.0s" (begin - (vector-ref (hash-table-ref (db:get-steps-table db test-id) "step1") 4))) + (vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4))) ;; (exit) ;;====================================================================== ;; R E M O T E C A L L S