| ︙ | | | ︙ | |
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))
|
| ︙ | | | ︙ | |
319
320
321
322
323
324
325
326
327
328
329
330
331
332
|
;;
(define (db:setup run-id #!key (local #f))
(let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dbstruct (make-dbr:dbstruct path: dbdir local: local)))
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)
|
>
>
|
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
|
;;
(define (db:setup run-id #!key (local #f))
(let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dbstruct (make-dbr:dbstruct path: dbdir local: local)))
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)
|
| ︙ | | | ︙ | |
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
|
(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!
|
<
|
816
817
818
819
820
821
822
823
824
825
826
827
828
829
|
(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))
|
| ︙ | | | ︙ | |
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
|
(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
|
|
>
>
>
>
>
>
>
>
>
|
|
>
|
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
|
(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
|
| ︙ | | | ︙ | |