Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1073,11 +1073,11 @@ (mutex-unlock! *incoming-mutex*) (if *cache-on* (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") (db:write-cached-data))) -(define (cdb:tests-register-test run-id test-name item-path) +(define (cdb:tests-register-test run-id test-name item-path #!key (force-write #f)) (let ((item-paths (if (equal? item-path "") (list item-path) (list item-path "")))) (debug:print 4 "INFO: Adding " run-id ", " test-name "/" item-path " for setting pass/fail counts to the queue") (mutex-lock! *incoming-mutex*) @@ -1085,11 +1085,11 @@ (set! *incoming-data* (cons (vector 'register-test (current-milliseconds) (list run-id test-name item-path)) ;; fail-count pass-count test-id)) *incoming-data*)) (mutex-unlock! *incoming-mutex*) - (if *cache-on* + (if (and (not force-write) *cache-on*) (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") (db:write-cached-data)))) ;; The queue is a list of vectors where the zeroth slot indicates the type of query to ;; apply and the second slot is the time of the query and the third entry is a list of @@ -1647,19 +1647,20 @@ (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count)) (cdb:pass-fail-counts test-id fail-count pass-count))) +;; currently forces a flush of the queue (define (rdb:tests-register-test run-id test-name item-path) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) - ((rpc:procedure 'cdb:tests-register-test host port) run-id test-name item-path)) - (cdb:tests-register-test run-id test-name item-path))) + ((rpc:procedure 'cdb:tests-register-test host port) run-id test-name item-path force-write: #t)) + (cdb:tests-register-test run-id test-name item-path force-write: #t))) (define (rdb:flush-queue) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'cdb:flush-queue host port))) (cdb:flush-queue))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -615,11 +615,10 @@ (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)) (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) (rdb:tests-register-test run-id test-name item-path) - (rdb:flush-queue) (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)))) (debug:print 4 "INFO: test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (open-run-close db:get-test-info-by-id db test-id)))) (set! test-id (db:test-get-id testdat)) (change-directory test-path)