Overview
Context
Changes
Modified common.scm
from [dd5b90ba4c]
to [a00194b355].
︙ | | |
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
|
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
|
-
+
-
+
-
+
-
-
-
+
+
+
|
;;
(define (common:readonly-watchdog dbstruct)
(thread-sleep! 0.05) ;; delay for startup
(BB> "common:readonly-watchdog entered.")
;; sync megatest.db to /tmp/.../megatst.db
(let ((sync-cool-off-duration 3)
(let* ((sync-cool-off-duration 3)
(golden-mtdb (dbr:dbstruct-mtdb dbstruct))
(golden-mtpath (db:dbdat-get-path mtdb))
(golden-mtpath (db:dbdat-get-path golden-mtdb))
(tmp-mtdb (dbr:dbstruct-tmpdb dbstruct))
(tmp-mtpath (db:dbdat-get-path mtdb)))
(tmp-mtpath (db:dbdat-get-path tmp-mtdb)))
(debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
(let loop ((last-sync-time 0))
(BB> "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
(let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
(BB> "duration-since-last-sync="duration-since-last-sync)
(if (and (not *time-to-exit*)
(< duration-since-last-sync sync-cool-off-duration))
(thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
(if (not *time-to-exit*)
(let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
(tmp-mtdb-mtime (file-modification-time tmp-mtpath)))
(if (> golden-mtdb-mtime tmp-mtdb-mtime)
(let ((res (db:multi-db-sync dbstruct 'old2new)))
(debug:print-info 0 *default-log-port* "rosync called, " res " records transferred."))
(loop (current-seconds)))
#t))))
(debug:print-info 0 *default-log-port* "rosync called, " res " records transferred.")))
(loop (current-seconds)))
#t)))
(debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
(define (common:writable-watchdog dbstruct)
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
|
︙ | | |
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
|
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
|
-
+
|
;;#t)
(BB> "common:watchdog entered.")
(let ((dbstruct (db:setup)))
(cond
((dbr:dbstruct-read-only dbstruct)
(BB> "loading read-only watchdog")
common:readonly-watchdog dbstruct)
(common:readonly-watchdog dbstruct))
(else
(BB> "loading writable-watchdog.")
(common:writable-watchdog dbstruct))))
(BB> "watchdog done.");;)
)
|
︙ | | |
Modified db.scm
from [728a319e47]
to [d266ac8ea7].
︙ | | |
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
|
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
|
-
+
|
(dbfexists (file-exists? (conc dbpath "/megatest.db")))
(tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
(mtdb (db:open-megatest-db))
(mtdbpath (db:dbdat-get-path mtdb))
(mtdbexists (file-exists? mtdbpath))
(refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
(write-access (file-write-access? mtdbpath)))
(BB> "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
;;(BB> "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
(if (and dbexists (not write-access))
(begin (set! *db-write-access* #f)
(dbr:dbstruct-read-only-set! dbstruct #t)))
(dbr:dbstruct-mtdb-set! dbstruct mtdb)
(dbr:dbstruct-tmpdb-set! dbstruct tmpdb)
(dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
|
︙ | | |
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
|
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
|
-
+
|
(cond
(*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard
(else ;;(common:on-homehost?)
(let* ((dbstruct (make-dbr:dbstruct)))
(when (not *toppath*) (launch:setup areapath: areapath))
(db:open-db dbstruct areapath: areapath)
(set! *dbstruct-db* dbstruct)
(BB> "new dbstruct = "(dbr:dbstruct->alist dbstruct))
;;(BB> "new dbstruct = "(dbr:dbstruct->alist dbstruct))
dbstruct))))
;; (else
;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost))
;; (exit 1))))
;; Open the classic megatest.db file (defaults to open in toppath)
;;
|
︙ | | |