Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -81,11 +81,11 @@ ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -49,11 +49,11 @@ (define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) (define *alt-log-file* #f) ;; used by -log (define *db-sync-mutex* (make-mutex)) ;; DATABASE -(define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs +(define *dbstruct-db* #f) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) (define *megatest-db* #f) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -171,11 +171,15 @@ "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" (* run-id 30000) ;; allow for up to 30k tests per run run-id) ))) ;; add strings db to rundb, not in use yet ;; )) ;; (sqlite3:open-database dbpath)) - (olddb (db:open-megatest-db)) + (olddb (if *megatest-db* + *megatest-db* + (let ((db (db:open-megatest-db))) + (set! *megatest-db* db) + db))) (write-access (file-write-access? dbpath)) ;; (handler (make-busy-timeout 136000)) ) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) ;; only unset so other db's also can use this control @@ -282,14 +286,15 @@ (if local (for-each (lambda (db) (if (sqlite3:database? db) (sqlite3:finalize! db))) - (hash-table-values (dbr:dbstruct-get-locdbs dbstruct))) + (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) + (if rundb (if (sqlite3:database? rundb) (sqlite3:finalize! rundb) - (debug:print 0 "WARNING: attempting to close databases but got " rundb " instead of a database"))))) + (debug:print 2 "WARNING: attempting to close databases but got " rundb " instead of a database"))))) (define (db:open-inmem-db) (let* ((db (sqlite3:open-database ":memory:")) (handler (make-busy-timeout 3600))) (db:initialize-run-id-db db) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -345,10 +345,14 @@ (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) +(on-exit (lambda () + (if *megatest-db* + (db:close-all *megatest-db*)))) + ;;====================================================================== ;; Misc general calls ;;====================================================================== (if (args:get-arg "-env2file") Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -65,18 +65,17 @@ cinfo ;; if read only query and server not already running ;; bypass starting the server. ;; ;; NB// can cache the answer for server running for 10 seconds ... - ;; - (if (and (not (rmt:write-frequency-over-limit? cmd run-id)) - (not (open-run-close tasks:server-running-or-starting? tasks:open-db run-id))) - #f + ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) + (if (open-run-close tasks:server-running-or-starting? tasks:open-db run-id) (let ((res (client:setup run-id))) (if res (hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully) - #f)))))) + #f)) + #f)))) (jparams (db:obj->string params))) (if connection-info (let ((res (http-transport:client-api-send-receive run-id connection-info cmd jparams))) (if res (db:string->obj res) @@ -87,16 +86,19 @@ (debug:print-info 4 "no server and read-only query, bypassing normal channel") (rmt:open-qry-close-locally cmd run-id params))))) (define (rmt:open-qry-close-locally cmd run-id params) (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dbstruct-local (make-dbr:dbstruct path: dbdir - local: #t)) + (dbstruct-local (if *megatest-db* + *megatest-db* + (let ((db (make-dbr:dbstruct path: dbdir local: #t))) + (set! *megatest-db* db) + db))) (db-file-path (db:dbfile-path 0)) ;; (read-only (not (file-read-access? db-file-path))) (res (api:execute-requests dbstruct-local (symbol->string cmd) params))) - (db:close-all dbstruct-local) + ;; (db:close-all dbstruct-local) res)) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) (jparams (db:obj->string params)) ;; (rmt:dat->json-str params))