@@ -12,11 +12,12 @@ ;;====================================================================== ;; Database access ;;====================================================================== (require-extension (srfi 18) extras tcp) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n + md5 message-digest base64 format dot-locking z3 defstruct) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit db)) (declare (uses common)) @@ -87,20 +88,20 @@ (define (db:done-with dbstruct run-id mod-read) (if (not (sqlite3:database? dbstruct)) (begin (mutex-lock! *rundb-mutex*) (if (eq? mod-read 'mod) - (dbr:dbstruct-set-mtime! dbstruct (current-milliseconds)) - (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds))) - (dbr:dbstruct-set-inuse! dbstruct #f) + (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds)) + (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds))) + (dbr:dbstruct-inuse-set! dbstruct #f) (mutex-unlock! *rundb-mutex*)))) ;; (db:with-db dbstruct run-id sqlite3:exec "select blah from 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) - (let* ((dbdat (if (vector? dbstruct) + (let* ((dbdat (if (dbr:dbstruct? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; cheat, allow for passing in a dbdat (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) (handle-exceptions @@ -188,14 +189,14 @@ (sqlite3:open-database fname))))) ;; ) ;; This routine creates the db. It is only called if the db is not already opened ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let* ((local (dbr:dbstruct-get-local dbstruct)) + (let* ((local (dbr:dbstruct-local dbstruct)) (rdb (if local - (dbr:dbstruct-get-localdb dbstruct run-id) - (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) + (dbr:dbstruct-localdb-set! dbstruct run-id) + (dbr:dbstruct-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb do-not-open) rdb (begin (mutex-lock! *rundb-mutex*) @@ -230,36 +231,36 @@ (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 - (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) - (dbr:dbstruct-set-inuse! dbstruct #t) - (dbr:dbstruct-set-olddb! dbstruct olddb) + (dbr:dbstruct-rundb-set! dbstruct (cons db dbpath)) + (dbr:dbstruct-inuse-set! dbstruct #t) + (dbr:dbstruct-olddb-set! dbstruct olddb) ;; (dbr:dbstruct-set-run-id! dbstruct run-id) (mutex-unlock! *rundb-mutex*) (if local (begin - (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... + (dbr:dbstruct-localdb-set! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... db) (begin - (dbr:dbstruct-set-inmem! dbstruct inmem) + (dbr:dbstruct-inmem-set! dbstruct inmem) ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context (db:sync-tables db:sync-tests-only db inmem) (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? - (dbr:dbstruct-set-refdb! dbstruct refdb) + (dbr:dbstruct-refdb-set! dbstruct refdb) (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db ;; sync once more to deal with delays? ;; (db:sync-tables db:sync-tests-only db inmem) ;; (db:sync-tables db:sync-tests-only inmem refdb) inmem))))))) ;; This routine creates the db. It is only called if the db is not already ls opened ;; (define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let ((mdb (dbr:dbstruct-get-main dbstruct))) + (let ((mdb (dbr:dbstruct-main dbstruct))) (if mdb mdb (begin (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path 0)) @@ -268,12 +269,12 @@ (olddb (db:open-megatest-db)) (write-access (file-write-access? dbpath)) (dbdat (cons db dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) - (dbr:dbstruct-set-main! dbstruct dbdat) - (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) + (dbr:dbstruct-main-set! dbstruct dbdat) + (dbr:dbstruct-olddb-set! dbstruct olddb) ;; olddb is already a (cons db path) (mutex-unlock! *rundb-mutex*) (if (and (not dbexists) *db-write-access*) ;; did not have a prior db and do have write access (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically dbdat))))) @@ -300,17 +301,17 @@ (cons db dbpath))) ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) - (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) - (stime (dbr:dbstruct-get-stime dbstruct)) - (rundb (dbr:dbstruct-get-rundb dbstruct)) - (inmem (dbr:dbstruct-get-inmem dbstruct)) - (maindb (dbr:dbstruct-get-main dbstruct)) - (refdb (dbr:dbstruct-get-refdb dbstruct)) - (olddb (dbr:dbstruct-get-olddb dbstruct)) + (let ((mtime (dbr:dbstruct-mtime dbstruct)) + (stime (dbr:dbstruct-stime dbstruct)) + (rundb (dbr:dbstruct-rundb dbstruct)) + (inmem (dbr:dbstruct-inmem dbstruct)) + (maindb (dbr:dbstruct-main dbstruct)) + (refdb (dbr:dbstruct-refdb dbstruct)) + (olddb (dbr:dbstruct-olddb dbstruct)) ;; (runid (dbr:dbstruct-get-run-id dbstruct)) ) (debug:print-info 4 "Syncing for run-id: " run-id) ;; (mutex-lock! *http-mutex*) (if (eq? run-id 0) @@ -322,11 +323,11 @@ force-sync) (begin (db:delay-if-busy maindb) (db:delay-if-busy olddb) (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) num-synced) 0)) (begin ;; this can occur when using local access (i.e. not in a server) ;; need a flag to turn it off. @@ -339,33 +340,33 @@ (> mtime stime) force-sync) (begin (db:delay-if-busy rundb) (db:delay-if-busy olddb) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) ;; (mutex-unlock! *http-mutex*) num-synced) (begin ;; (mutex-unlock! *http-mutex*) 0)))))) (define (db:close-main dbstruct) - (let ((maindb (dbr:dbstruct-get-main dbstruct))) + (let ((maindb (dbr:dbstruct-main dbstruct))) (if maindb (begin (sqlite3:finalize! (db:dbdat-get-db maindb)) - (dbr:dbstruct-set-main! dbstruct #f))))) + (dbr:dbstruct-main-set! dbstruct #f))))) (define (db:close-run-db dbstruct run-id) (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) (if (and rdb (sqlite3:database? rdb)) (begin (sqlite3:finalize! rdb) - (dbr:dbstruct-set-localdb! dbstruct run-id #f) - (dbr:dbstruct-set-inmem! dbstruct #f))))) + (dbr:dbstruct-localdb-set! dbstruct run-id #f) + (dbr:dbstruct-inmem-set! dbstruct #f))))) ;; close all opened run-id dbs (define (db:close-all dbstruct) ;; finalize main.db (db:sync-touched dbstruct 0 force-sync: #t) @@ -372,11 +373,11 @@ ;;(common:db-block-further-queries) ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? (db:close-main dbstruct) - (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) + (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) (if (hash-table? locdbs) (for-each (lambda (run-id) (db:close-run-db dbstruct run-id)) (hash-table-keys locdbs))))