| ︙ | | | ︙ | |
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
;; 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)
(if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through
dbstruct
(begin
dbdat))))
;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
(if (pair? dbdat)
(car dbdat)
dbdat))
|
>
>
|
>
|
|
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
;; 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)
(if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through
dbstruct
(if (pair? dbstruct)
dbstruct ;; pass pair ( db . path ) on through
(begin
;; (assert (dbr:dbstruct? dbstruct)) ;; so much legacy, but by here we should have a genuine dbstruct
(let ((dbdat (if (or (not run-id)
(eq? run-id 0))
(db:open-main dbstruct)
(db:open-rundb dbstruct run-id)
)))
dbdat)))))
;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
(if (pair? dbdat)
(car dbdat)
dbdat))
|
| ︙ | | | ︙ | |
334
335
336
337
338
339
340
341
342
343
344
345
346
347
|
(define (db:open-local-db-handle)
(or *dbstruct-db*
(let ((dbstruct (db:setup #f local: #t)))
(set! *dbstruct-db* dbstruct)
dbstruct)))
;; Open the classic megatest.db file in toppath
;;
(define (db:open-megatest-db #!key (path #f))
(let* ((dbpath (or path (conc *toppath* "/megatest.db")))
(dbexists (file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
(db:initialize-main-db db)
|
>
>
|
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
|
(define (db:open-local-db-handle)
(or *dbstruct-db*
(let ((dbstruct (db:setup #f local: #t)))
(set! *dbstruct-db* dbstruct)
dbstruct)))
;; Open the classic megatest.db file in toppath
;;
;; NOTE: returns a dbdat not a dbstruct!
;;
(define (db:open-megatest-db #!key (path #f))
(let* ((dbpath (or path (conc *toppath* "/megatest.db")))
(dbexists (file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
(db:initialize-main-db db)
|
| ︙ | | | ︙ | |
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
|
(if (eq? access-mode 'cached)
(apply db:call-with-cached-db db-cmd params)
(apply rmt-cmd params)))
;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f))
;; (common:sync-to-megatest.db #t) ;; BUG!! DON'T LEAVE THIS HERE!
|
<
|
831
832
833
834
835
836
837
838
839
840
841
842
843
844
|
(if (eq? access-mode 'cached)
(apply db:call-with-cached-db db-cmd params)
(apply rmt-cmd params)))
;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f))
(if (and (hash-table-ref/default *global-db-store* target #f)
(>= (file-modification-time target)(file-modification-time source)))
(hash-table-ref *global-db-store* target)
(let* ((toppath (launch:setup))
(targ-db-last-mod (if (file-exists? target)
(file-modification-time target)
0))
|
| ︙ | | | ︙ | |
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
|
(define (db:call-with-cached-db proc . params)
;; first cache the db in /tmp
(let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
(fname (conc (common:get-area-path-signature) ".db"))
(cache-dir (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name) "/" cname-part)
(conc "/tmp/" (current-user-name) "-" cname-part)
(conc "/tmp/" (current-user-name) "_" cname-part)))))
;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
(if (not cache-dir)
(begin
(debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
(exit 1))
(let* ((cache-db (db:cache-for-read-only
(conc *toppath* "/megatest.db")
(conc cache-dir "/" fname)
use-last-update: #t)))
(apply proc cache-db params)
))))
;; options:
;;
;; 'killservers - kills all servers
;; 'dejunk - removes junk records
|
|
>
>
>
>
>
>
>
>
>
|
|
>
|
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
|
(define (db:call-with-cached-db proc . params)
;; first cache the db in /tmp
(let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
(fname (conc (common:get-area-path-signature) ".db"))
(cache-dir (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name) "/" cname-part)
(conc "/tmp/" (current-user-name) "-" cname-part)
(conc "/tmp/" (current-user-name) "_" cname-part))))
(megatest-db (conc *toppath* "/megatest.db")))
;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
(if (not cache-dir)
(begin
(debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
(exit 1))
(let* ((th1 (make-thread
(lambda ()
(if (and (file-exists? megatest-db)
(file-write-access? megatest-db))
(begin
(common:sync-to-megatest.db 'timestamps) ;; internally mutexes on *db-local-sync*
(debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
"call-with-cached-db sync-to-megatest.db"))
(cache-db (db:cache-for-read-only
megatest-db
(conc cache-dir "/" fname)
use-last-update: #t)))
(thread-start! th1)
(apply proc cache-db params)
))))
;; options:
;;
;; 'killservers - kills all servers
;; 'dejunk - removes junk records
|
| ︙ | | | ︙ | |