Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -397,11 +397,11 @@ (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:")) (sleep 2) (db:multi-db-sync - (db:setup #t) ;; (db:setup-db *dbstruct-dbs* *toppath* #f) + (db:setup #t *toppath*) ;; (db:setup-db *dbstruct-dbs* *toppath* #f) 'killservers ;'dejunk ;'adj-testids 'old2new ) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -135,11 +135,11 @@ (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog (define *default-area-tag* "local") ;; DATABASE -(define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. +;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. ;; db stats (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) ;; db access (define *db-last-access* (current-seconds)) ;; last db access, used in server @@ -593,11 +593,11 @@ (if (common:on-homehost?) (if (common:api-changed?) (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) (read-only (not (file-write-access? dbfile))) - (dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t))) + (dbstruct (db:setup #t *toppath*))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t))) (debug:print 0 *default-log-port* "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) (cond Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -133,39 +133,55 @@ ", error: " ((condition-property-accessor 'exn 'message) exn) ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) ", location: " ((condition-property-accessor 'exn 'location) exn) )) +(define (db:setup do-sync) + (assert *toppath* "FATAL: db:setup called before launch:setup has been run.") + (dbfile:setup do-sync *toppath*)) + ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db ;; if run-id is a string treat it as a filename ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; -(define (db:get-db dbstruct run-id) ;; RENAME TO db:get-dbh - (let* ((subdb (dbfile:get-subdb dbstruct run-id))) +(define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh + ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id))) (if (stack? (dbr:subdb-dbstack subdb)) (if (stack-empty? (dbr:subdb-dbstack subdb)) (let* ((dbname (db:run-id->dbname run-id)) (newdb (db:open-megatest-db path: (db:dbfile-path) name: dbname))) ;; NOTE: pushing on the stack only happens AFTER the handle has been used ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) newdb) (stack-pop! (dbr:subdb-dbstack subdb))) - (db:open-db subdb run-id)))) + (db:open-db subdb run-id))) ;; ) (define-inline (db:generic-error-printout exn . message) (print-call-chain (current-error-port)) (apply debug:print-error 0 *default-log-port* message) (debug:print-error 0 *default-log-port* " params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) ", location: " ((condition-property-accessor 'exn 'location) exn) )) + +;; looks up subdb and returns it, if not found then set up +;; and then return it. +;; +(define (db:get-subdb dbstruct run-id) + (let* ((res (dbfile:get-subdb dbstruct run-id))) + (if res + res + (let* ((newsubdb (make-dbr:subdb))) + (db:open-db newsubdb run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t) + (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) newsubdb) + newsubdb)))) ;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) @@ -366,36 +382,10 @@ db "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") last-update-time)) -;; Make the dbstruct, setup up auxillary db's and call for main db at least once -;; -;; called in http-transport and replicated in rmt.scm for *local* access. -;; -(define (db:setup do-sync #!key (areapath #f)) - ;; - (cond - (*dbstruct-dbs* *dbstruct-dbs*);; TODO: when multiple areas are supported, this optimization will be a hazard - (else ;;(common:on-homehost?) - (let* ((dbstructs (make-dbr:dbstruct))) - (when (not *toppath*) - (debug:print-info 0 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") - (launch:setup areapath: areapath)) - (set! *dbstruct-dbs* dbstructs) - (dbr:dbstruct-areapath-set! dbstructs *toppath*) - dbstructs)))) - -(define (dbfile:get-subdb dbstruct run-id) - (let* ((res (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) #f))) - (if res - res - (let* ((newsubdb (make-dbr:subdb))) - (db:open-db newsubdb run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t) - (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) newsubdb) - newsubdb)))) - ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; @@ -4993,11 +4983,11 @@ ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (define (common:watchdog) (debug:print-info 13 *default-log-port* "common:watchdog entered.") (if (launch:setup) (if (common:on-homehost?) - (let ((dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t))) + (let ((dbstruct (db:setup #t *toppath*))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t))) (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) (cond ((dbr:dbstruct-read-only dbstruct) (debug:print-info 13 *default-log-port* "loading read-only watchdog") (common:readonly-watchdog dbstruct)) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -53,11 +53,11 @@ (dbname #f) ;; .db/1.db (mtdb #f) ;; mtrah/.db/1.db ;; (dbdats (make-hash-table)) ;; id => dbdat (tmpdb #f) ;; /tmp/.../.db/1.db (refndb #f) ;; /tmp/.../.db/1.db_ref - (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack + (dbstack (make-stack)) ;; stack for tmp db handles, ????? why => do not initialize with a stack (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) (last-sync 0) (last-write (current-seconds)) @@ -67,10 +67,12 @@ (defstruct dbr:dbdat (dbfile #f) (dbh #f) (stmt-cache (make-hash-table)) (read-only #f)) + +(define *dbstruct-dbs* #f) (define (dbfile:run-id->key run-id) (or run-id 'main)) (define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) @@ -154,10 +156,35 @@ (define (db:run-id->dbname run-id) (cond ((number? run-id) (conc ".db/" (modulo run-id 100) ".db")) ((not run-id) (conc ".db/main.db")) (else run-id))) + +;; Make the dbstruct, setup up auxillary db's and call for main db at least once +;; +;; called in http-transport and replicated in rmt.scm for *local* access. +;; +(define (dbfile:setup do-sync areapath) + (cond + (*dbstruct-dbs* *dbstruct-dbs*);; TODO: when multiple areas are supported, this optimization will be a hazard + (else ;;(common:on-homehost?) + (let* ((dbstructs (make-dbr:dbstruct))) + #;(when (not *toppath*) + (debug:print-info 0 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") + (launch:setup areapath: areapath)) + (set! *dbstruct-dbs* dbstructs) + (dbr:dbstruct-areapath-set! dbstructs areapath) + dbstructs)))) + +#;(define (dbfile:get-subdb dbstruct run-id) + (let* ((res (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) #f))) + (if res + res + (let* ((newsubdb (make-dbr:subdb))) + (db:open-db newsubdb run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t) + (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) newsubdb) + newsubdb)))) (define (dbfile:get-subdb dbstruct run-id) (let* ((dbfname (db:run-id->dbname run-id))) (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -461,11 +461,11 @@ (start-time (current-milliseconds))) ;; Use this opportunity to sync the tmp db to megatest.db (if (not server-going) ;; *dbstruct-dbs* (begin (debug:print 0 *default-log-port* "SERVER: dbprep") - (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!! + (set! *dbstruct-dbs* (db:setup #t *toppath*)) ;; run-id)) FIXME!!! (set! server-going #t) (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine. (thread-start! *watchdog*))) ;; when things go wrong we don't want to be doing the various queries too often Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -2303,21 +2303,21 @@ (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close patch-db #f) - (let ((dbstructs (db:setup #f areapath: *toppath*))) + (let ((dbstructs (db:setup #f *toppath*))) (common:cleanup-db dbstructs full: #t)) (set! *didsomething* #t))) (if (args:get-arg "-cleanup-db") (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - (let ((dbstructs (db:setup #f areapath: *toppath*))) + (let ((dbstructs (db:setup #f *toppath*))) (common:cleanup-db dbstructs)) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin @@ -2372,11 +2372,11 @@ (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) (dbstructs (if (and toppath (common:on-homehost?)) - (db:setup #t) + (db:setup #t toppath) #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) (if *toppath* (cond ((getenv "MT_RUNSCRIPT") ;; How to run megatest scripts @@ -2461,26 +2461,29 @@ ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) ;; ;; ;; redo me (set! *didsomething* #t))) (if (args:get-arg "-import-megatest.db") (begin + (launch:setup) (db:multi-db-sync - (db:setup #f) + (db:setup #f *toppath*) 'killservers 'dejunk 'adj-testids 'old2new ;; 'new2old ) (set! *didsomething* #t))) (when (args:get-arg "-sync-brute-force") - ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t)) + (launch:setup) + ((server:get-bruteforce-syncer (db:setup #t *toppath*) persist-until-sync: #t)) (set! *didsomething* #t)) (if (args:get-arg "-sync-to-megatest.db") - (let* ((dbstruct (db:setup #f)) + (let* ((duh (launch:setup)) + (dbstruct (db:setup #f)) (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct))) (lockfile (conc tmpdbpth ".lock")) (locked (common:simple-file-lock lockfile)) (res (if locked (db:multi-db-sync Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -370,11 +370,11 @@ res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) (db-file-path (db:dbfile-path)) ;; 0)) - (dbstructs-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) + (dbstructs-local (db:setup #t *toppath*)) ;; make-dbr:dbstruct path: dbdir local: #t))) (read-only (not (file-write-access? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. ADDED tests/simplerun/thebeginning.scm Index: tests/simplerun/thebeginning.scm ================================================================== --- /dev/null +++ tests/simplerun/thebeginning.scm @@ -0,0 +1,12 @@ +(use trace test) +(import dbfile) +(trace-call-sites #t) + +(test #f #t (dbr:dbstruct? (db:setup #t))) +(define dbstruct *dbstruct-dbs*) +(test #f #f (dbfile:get-subdb dbstruct #f)) ;; get main.db (never opened yet) +(test #f #f (dbfile:get-subdb dbstruct 1)) ;; get 1.db + +(test #f #f (db:get-subdb dbstruct 1)) + +(test #f #f (stack? (dbr:subdb-dbstack subdb)))