Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -399,17 +399,17 @@
(define (common:legacy-sync-required)
(configf:lookup *configdat* "setup" "megatest-db"))
;; run-ids
-;; if #f use *db-local-sync*
-;; if #t use timestamps
+;; if #f use *db-local-sync* : or 'local-sync-flags
+;; if #t use timestamps : or 'timestamps
(define (common:sync-to-megatest.db run-ids)
(let ((start-time (current-seconds))
(run-ids-to-process (if (list? run-ids)
run-ids
- (if run-ids
+ (if (or (eq? run-ids 'timestamps)(eq? run-ids #t))
(db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db"))
(mtdb-exists (file-exists? mtdb-fpath)))
(if mtdb-exists
(file-modification-time mtdb-fpath)
0)))
@@ -429,12 +429,40 @@
(debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
(hash-table-delete! *db-local-sync* run-id)))
(mutex-unlock! *db-multi-sync-mutex*))
run-ids-to-process)))
+(define (common:watchdog)
+ (thread-sleep! 0.05) ;; delay for startup
+ (let ((legacy-sync (common:legacy-sync-required))
+ (debug-mode (debug:debug-mode 1))
+ (last-time (current-seconds)))
+ (if (or (common:legacy-sync-recommended)
+ legacy-sync)
+ (let loop ()
+ ;; sync for filesystem local db writes
+ ;;
+ (let ((start-time (current-seconds)))
+ (common:sync-to-megatest.db 'local-sync-flags)
+ (if (and debug-mode
+ (> (- start-time last-time) 60))
+ (begin
+ (set! last-time start-time)
+ (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
-
+ ;; keep going unless time to exit
+ ;;
+ (if (not *time-to-exit*)
+ (let delay-loop ((count 0))
+ (if (and (not *time-to-exit*)
+ (< count 4)) ;; was 11, changing to 4.
+ (begin
+ (thread-sleep! 1)
+ (delay-loop (+ count 1))))
+ (loop)))
+ (if (common:low-noise-print 30)
+ (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))))
(define (std-exit-procedure)
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -104,10 +104,19 @@
;;
(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
+
+;; create a watch dog to move changes from lt/.db/*.db to megatest.db
+;;
+(if (file-write-access? (conc *toppath* "/megatest.db"))
+ (thread-start! (make-thread common:watchdog "Watchdog thread"))
+ (if (not (args:get-arg "-use-db-cache"))
+ (begin
+ (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
+ (hash-table-set! args:arg-hash "-use-db-cache" #t))))
;; data common to all tabs goes here
;;
(defstruct dboard:commondat
((curr-tab-num 0) : number)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -89,17 +89,20 @@
;; 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
+ (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))))
+ dbdat)))))
;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
(if (pair? dbdat)
(car dbdat)
@@ -336,10 +339,12 @@
(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
@@ -828,11 +833,10 @@
(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!
(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)
@@ -856,20 +860,30 @@
(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)))))
+ (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* ((cache-db (db:cache-for-read-only
- (conc *toppath* "/megatest.db")
+ (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:
;;
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -243,13 +243,11 @@
(vector #t '())))
(success (vector-ref resdat 0))
(res (vector-ref resdat 1))
(duration (- (current-milliseconds) start)))
(if (and read-only qry-is-write)
- (begin
- (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)
- ))
+ (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
(if (not success)
(if (> remretries 0)
(begin
(debug:print-error 0 *default-log-port* "local query failed. Trying again.")
(thread-sleep! (/ (random 5000) 1000)) ;; some random delay