Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -140,11 +140,11 @@ (dbfile:setup do-sync *toppath*)) ;; looks up subdb and returns it, if not found then set up ;; and then return it. ;; -(define (db:get-db dbstruct run-id) +#;(define (db:get-db dbstruct run-id) (let* ((res (dbfile:get-subdb dbstruct run-id))) (if res res (let* ((newsubdb (make-dbr:subdb))) (dbfile:set-subdb dbstruct run-id newsubdb) @@ -187,11 +187,11 @@ ;; 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) (let* ((have-struct (dbr:dbstruct? dbstruct)) (dbdat (if have-struct ;; this stuff just allows us to call with a db handle directly - (db:get-db dbstruct run-id) + (db:get-subdb dbstruct run-id) #f)) (db (if have-struct ;; this stuff just allows us to call with a db handle directly (dbr:dbdat-dbh dbdat) dbstruct)) (fname (if dbdat @@ -242,11 +242,11 @@ ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; ;; (define *db-open-mutex* (make-mutex)) ;; -(define (db:lock-create-open fname initproc) +#;(define (db:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (raw-fname (pathname-file fname)) (dir-writable (file-write-access? parent-dir)) (file-exists (common:file-exists? fname)) (file-write (if file-exists @@ -313,15 +313,15 @@ (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) ))) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; -(define (db:open-db dbstruct run-id #!key (areapath #f)(do-sync #t)) +#;(define (db:open-db dbstruct run-id #!key (areapath #f)(do-sync #t)) (let* ((subdb (dbfile:get-subdb dbstruct run-id)) (tmpdb-stack (dbr:subdb-dbstack subdb))) (if (stack? tmpdb-stack) - (db:get-db tmpdb-stack run-id) ;; get previously opened db (will create new db handle if all in the stack are already used + (db:get-subdb tmpdb-stack run-id) ;; get previously opened db (will create new db handle if all in the stack are already used (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10)) (dbpath (db:dbfile-path)) ;; path to tmp db area (dbname (db:run-id->dbname run-id)) (dbexists (common:file-exists? dbpath)) (mtdbfname (conc *toppath* "/"dbname)) @@ -415,11 +415,11 @@ ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) (let* ((subdb (dbfile:get-subdb dbstruct run-id)) - (tmpdb (db:get-db dbstruct run-id)) + (tmpdb (db:get-subdb dbstruct run-id)) (mtdb (dbr:subdb-mtdb subdb)) (refndb (dbr:subdb-refndb subdb)) (start-t (current-seconds))) (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) (mutex-lock! *db-multi-sync-mutex*) @@ -1094,11 +1094,11 @@ (res '())) (for-each (lambda (subdb) (let* ((dbname (db:run-id->dbname run-id)) (mtdb (dbr:subdb-mtdb subdb)) - (tmpdb (db:get-db dbstruct run-id)) + (tmpdb (db:get-subdb dbstruct run-id)) (refndb (dbr:subdb-refndb subdb)) (newres (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb))) (stack-push! (dbr:subdb-dbstack subdb) tmpdb) (set! res (cons newres res)))) subdbs) @@ -1511,11 +1511,11 @@ ;; dneeded is minimum space needed, scan for existing archives that ;; are on disks with adequate space and already have this test/itempath ;; archived ;; (define (db:archive-get-allocations dbstruct testname itempath dneeded) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db (db (dbr:dbdat-dbh dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space (sqlite3:for-each-row (lambda (id archive-disk-id disk-path last-du last-du-time) @@ -1543,11 +1543,11 @@ ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db (db (dbr:dbdat-dbh dbdat)) (res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) @@ -1573,11 +1573,11 @@ ;; record an archive path created on a given archive disk (identified by it's bdisk-id) ;; if path starts with / then it is full, otherwise it is relative to the archive disk ;; preference is to store the relative path. ;; (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db (db (dbr:dbdat-dbh dbdat)) (res #f)) ;; first look to see if this path is already registered (sqlite3:for-each-row (lambda (id) @@ -1626,11 +1626,11 @@ "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;" archive-block-id) res)))) ;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) -;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db +;; (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db ;; (db (dbr:dbdat-dbh dbdat)) ;; (res '()) ;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space ;; (sqlite3:for-each-row #f) @@ -3895,11 +3895,11 @@ (else msg))) ;; rpc ;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items ;; ; ;; define (db:test-set-state-status dbstruct run-id test-id state status msg) -;; (let ((dbdat (db:get-db dbstruct run-id))) +;; (let ((dbdat (db:get-subdb dbstruct run-id))) ;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) ;; (db:general-call dbdat 'set-test-start-time (list test-id))) ;; ;; (if msg ;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) ;; ;; (db:general-call dbdat 'state-status (list state status test-id))) @@ -4834,11 +4834,11 @@ (assert #f "FATAL: call to db:extract-ods-file which is not ported yet.") (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) - (dbdat (db:get-db dbstruct)) + (dbdat (db:get-subdb dbstruct)) (db (dbr:dbdat-dbh dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 (map car keypatt-alist) ; + N = length keypatt-alist Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -27,10 +27,12 @@ (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 stack + files + ports ) ;; (import debugprint) ;;====================================================================== @@ -41,10 +43,11 @@ ;; managed in a dbstruct ;; (defstruct dbr:dbstruct (areapath #f) (homehost #f) + (tmppath #f) (read-only #f) (subdbs (make-hash-table)) ) ;; NOTE: Need one dbr:subdb per main.db, 1.db ... @@ -104,20 +107,20 @@ ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))) (for-each (lambda (subdb) (let* ((tdbs (stack->list (dbr:subdb-dbstack subdb))) - (mdb (dbr:dbdat-dbh (dbr:subdb-mtdb subdb))) - (rdb (dbr:dbdat-dbh (dbr:subdb-refndb subdb)))) + (mtdbdat (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb))) + #;(rdb (dbr:dbdat-dbh (dbr:subdb-refndb subdb)))) (map (lambda (dbdat) (let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat)) (dbh (dbr:dbdat-dbh dbdat))) (db:safely-close-sqlite3-db dbh stmt-cache))) tdbs) - (db:safely-close-sqlite3-db mdb #f) ;; stmt-cache) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) - (db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) + (db:safely-close-sqlite3-db mtdbdat #f) ;; stmt-cache) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) + #;(db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) subdbs)))) ;; ) ;; ;; set up a single db (e.g. main.db, 1.db ... etc.) ;; ;; @@ -146,17 +149,17 @@ ;; 1234 => 4/1234.db ;; #f => 0/main.db ;; (abandoned the idea of num/db) ;; -(define (db:run-id->path apath run-id) - (conc apath"/"(db:run-id->dbname run-id))) +(define (dbfile:run-id->path apath run-id) + (conc apath"/"(dbfile:run-id->dbname run-id))) (define (db:dbname->path apath dbname) (conc apath"/"dbname)) -(define (db:run-id->dbname run-id) +(define (dbfile: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))) @@ -185,15 +188,15 @@ (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))) + (let* ((dbfname (dbfile:run-id->dbname run-id))) (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f))) (define (dbfile:set-subdb dbstruct run-id subdb) - (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (db:run-id->dbname run-id) subdb)) + (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb)) ;; 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 @@ -210,55 +213,66 @@ ;; return a previously opened db handle to the stack of available handles (define (dbfile:add-dbdat dbstruct run-id dbdat) (let* ((subdb (dbfile:get-subdb dbstruct run-id))) (stack-push! (dbr:subdb-dbstack subdb) dbdat))) -;; returns the dbstruct with needed data populated +;; set up a subdb +;; +(define (dbfile:init-subdb dbstruct run-id init-proc) + (let* ((dbname (dbfile:run-id->dbname run-id)) + (areapath (dbr:dbstruct-areapath dbstruct)) + (tmppath (dbr:dbstruct-tmppath dbstruct)) + (mtdbpath (dbfile:run-id->path areapath run-id)) + (tmpdbpath (dbfile:run-id->path tmppath run-id)) + (mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc)) + (tmpdbdat (dbfile:open-sqlite3-db tmpdbpath init-proc)) ;; push this on the stack + (newsubdb (make-dbr:subdb dbname: dbname + mtdbfile: mtdbpath + tmpdbfile: tmpdbpath + mtdbdat: mtdbdat))) + (dbfile:add-dbdat dbstruct run-id tmpdbdat) + (dbfile:set-subdb dbstruct run-id newsubdb) + newsubdb)) ;; return the new subdb - but shouldn't really use it + +;; returns dbdat with dbh and dbfilepath ;; 1. if needed setup the subdb for the given run-id ;; 2. if there is no existing db handle in the stack ;; create a new handle and return it (do NOT add ;; it to the stack). ;; (define (dbfile:open-db dbstruct run-id init-proc) (let* ((subdb (dbfile:get-subdb dbstruct run-id))) (if (not subdb) ;; not yet defined - (let* ((dbname (db:run-id->dbname run-id)) - (areapath (dbr:dbstruct-areapath dbstruct)) - (tmppath (dbr:dbstruct-tmppath dbstruct)) - (mtdbpath (db:run-id->path areapath run-id)) - (tmpdbpath (db:run-id->path tmppath run-id)) - (mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc)) - (tmpdbdat (dbfile:open-sqlite3-db tmpdbpath init-proc)) ;; push this on the stack - (newsubdb (make-dbr:subdb dbname: dbname - mtdbfile: mtdbpath - tmpdbfile: tmpdbpath - mtdbdat: mtdbdat))) - (dbfile:add-dbdat dbstruct run-id tmpdbdat) - (dbfile:set-subdb dbstruct run-id newsubdb) + (begin + (dbfile:init-subdb dbstruct run-id init-proc) (dbfile:open-db dbstruct run-id init-proc)) (let* ((dbdat (dbfile:get-dbdat dbstruct run-id))) (if dbdat dbdat (let* ((tmppath (dbr:dbstruct-tmppath dbstruct)) - (tmpdbpath (db:run-id->path tmppath run-id))) + (tmpdbpath (dbfile:run-id->path tmppath run-id))) (dbfile:open-sqlite3-db tmpdbpath init-proc))))))) ;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open ;; ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; -(define (dbfile:open-sqlite-db dbpath init-proc) +(define (dbfile:open-sqlite3-db dbpath init-proc) (let* ((dbexists (file-exists? dbpath)) - (db (dbfile:lock-create-open dbpath + (db ;; need locking here so multiple open + ;; do not collide + (let* ((db (sqlite3:open-database dbpath))) + (init-proc db)) + #;(dbfile:lock-create-open dbpath (lambda (db) - (db:initialize-main-db db)))) + (init-proc db)))) (write-access (file-write-access? dbpath))) - (dbfile:print-err "db:open-megatest-db "dbpath) - (if (and dbexists (not write-access)) + (dbfile:print-err "db:open-sqlite-db "dbpath) + #;(if (and dbexists (not write-access)) (set! *db-write-access* #f)) ;; (cons db dbpath))) (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access)))) (define (dbfile:print-and-exit . params) @@ -278,11 +292,11 @@ ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; ;; (define *db-open-mutex* (make-mutex)) ;; -(define (dbfile:lock-create-open fname initproc) +#;(define (dbfile:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (raw-fname (pathname-file fname)) (dir-writable (file-write-access? parent-dir)) (file-exists (file-exists? fname)) (file-write (if file-exists @@ -343,16 +357,16 @@ ))) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; -(define (db:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t)) +#;(define (db:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t)) (let* ((subdb (dbfile:get-subdb dbstruct run-id)) (tmpdb-stack (dbr:subdb-dbstack subdb)) (max-stale-tmp (dbr:dbstruct-max-stale-secs dbstruct));; (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10)) (dbpath (dbr:dbstruct-tmppath dbstruct)) ;; (db:dbfile-path)) ;; path to tmp db area - (dbname (db:run-id->dbname run-id)) + (dbname (dbfile:run-id->dbname run-id)) (dbexists (file-exists? dbpath)) (areapath (dbr:dbstruct-areapath dbstruct)) (mtdbfname (conc areapath "/"dbname)) (mtdbexists (file-exists? mtdbfname)) (mtdbmodtime (if mtdbexists (dbfile:lazy-sqlite-db-modification-time mtdbfname) #f)) Index: tests/simplerun/thebeginning.scm ================================================================== --- tests/simplerun/thebeginning.scm +++ tests/simplerun/thebeginning.scm @@ -4,18 +4,21 @@ (trace ;; dbfile:get-subdb ) +(test #f #t (dbr:dbstruct? (dbfile:setup #t *toppath*))) (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 #t (hash-table? (dbr:dbstruct-subdbs dbstruct))) -(test #f #t (sqlite3:database? (db:open-db dbstruct #f))) -(test #f #t (sqlite3:database? (db:open-db dbstruct 1))) +(test #f #t (dbr:dbdat? (dbfile:get-dbdat *dbstruct-dbs* #f))) -(test #f #t (stack? (dbr:subdb-dbstack subdb -(test #f #f (db:get-subdb dbstruct 1)) - -;; (test #f #f (stack? (dbr:subdb-dbstack subdb))) +;; test #f #t (sqlite3:database? (db:open-db dbstruct #f))) +;; test #f #t (sqlite3:database? (db:open-db dbstruct 1))) +;; +;; test #f #t (stack? (dbr:subdb-dbstack subdb +;; test #f #f (db:get-subdb dbstruct 1)) +;; +;; ; (test #f #f (stack? (dbr:subdb-dbstack subdb)))