Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -471,10 +471,25 @@ ))) dbfiles) (if dbdat (dbfile:add-dbdat dbstruct #f dbdat))) #t) +(define (db:kill-servers) + (let* ((servers (server:choose-server *toppath* 'all-valid))) ;; (server:get-list *toppath*)) + (for-each + (lambda (server) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " server ", exn=" exn) + #f) + (match-let (((mod-time host port start-time server-id pid) server)) + (if (and host pid) + (tasks:kill-server host pid))))) + servers) + (delete-file* (common:get-sync-lock-filepath)))) + ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records ;; 'adj-testids - move test-ids into correct ranges @@ -485,109 +500,83 @@ ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync dbstruct . options) (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc)) (data-synced 0) ;; count of changed records - (tmp-area (common:get-db-tmp-area)) - (old2new (member 'old2new options)) - (dejunk (member 'dejunk options)) - (killservers (member 'killservers options)) - (servers (server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath*)) - (src-area (if old2new *toppath* tmp-area)) - (dest-area (if old2new tmp-area *toppath*)) - (dbfiles (if old2new (glob (conc *toppath* "/.megatest/*.db")) (glob (conc tmp-area "/.megatest/*.db")))) - (keys (db:get-keys dbstruct)) - (sync-durations (make-hash-table))) - - (if (and killservers servers) - (begin - (for-each - (lambda (server) - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " server ", exn=" exn) - #f) - (match-let (((mod-time host port start-time server-id pid) server)) - (if (and host pid) - (tasks:kill-server host pid))))) - servers) - (delete-file* (common:get-sync-lock-filepath)) - ) - ) - + (tmp-area (common:get-db-tmp-area)) + (old2new (member 'old2new options)) + (dejunk (member 'dejunk options)) + (killservers (member 'killservers options)) + (src-area (if old2new *toppath* tmp-area)) + (dest-area (if old2new tmp-area *toppath*)) + (dbfiles (if old2new (glob (conc *toppath* "/.megatest/*.db")) (glob (conc tmp-area "/.megatest/*.db")))) + (keys (db:get-keys dbstruct)) + (sync-durations (make-hash-table))) + + ;; kill servers + (if (and killservers servers)(db:kill-servers)) + (if (not dbfiles) - (debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.megatest")) - (for-each - (lambda (srcfile) - (debug:print-info 3 *default-log-port* "file: " srcfile) - (let* ((fname (conc (pathname-file srcfile) ".db")) - (basename (pathname-file srcfile)) - (run-id (if (string= basename "main") #f (string->number basename))) - (destfile (conc dest-area "/.megatest/" fname)) - (dest-directory (conc dest-area "/.megatest/")) - (dummy (debug:print-info 2 *default-log-port* "destfile = " destfile)) - (dummy2 (debug:print-info 2 *default-log-port* "dejunk = " dejunk)) - (time1 (file-modification-time srcfile)) - (time2 (if (file-exists? destfile) - (begin - (debug:print-info 2 *default-log-port* "destfile " destfile " exists") - (file-modification-time destfile) - ) - (begin - (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile) - 0))) - (changed ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds - - (do-cp (cond - ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover - (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile) - ;; TODO: Need to fix this for WAL mod. Can't just copy. - (system (conc "/bin/mkdir -p " dest-directory)) - (system (conc "/bin/cp " srcfile " " destfile)) - #t) - (changed ;; (and changed - ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed. - #t) - ((and changed *time-to-exit*) ;; last sync - #t) - (else - #f)))) - (if (or dejunk do-cp) - (let* ( - (start-time (current-milliseconds)) - - (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc))) - (mtdb (dbr:subdb-mtdbdat subdb)) - (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc)) - - ) - (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds") - - (if old2new - (begin - (if dejunk (db:clean-up run-id mtdb)) - (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f mtdb tmpdb) - ) - (begin - (if dejunk (db:clean-up run-id tmpdb)) - (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f tmpdb mtdb) - ) - ) - (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time))) - (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date") - ) - ) - ) - dbfiles - ) - ) - data-synced - ) -) - - + (debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.megatest")) + (for-each + (lambda (srcfile) + (debug:print-info 3 *default-log-port* "file: " srcfile) + (let* ((fname (conc (pathname-file srcfile) ".db")) + (basename (pathname-file srcfile)) + (run-id (if (string= basename "main") #f (string->number basename))) + (destfile (conc dest-area "/.megatest/" fname)) + (dest-directory (conc dest-area "/.megatest/")) + (time1 (file-modification-time srcfile)) + (time2 (if (file-exists? destfile) + (begin + (debug:print-info 2 *default-log-port* "destfile " destfile " exists") + (file-modification-time destfile)) + (begin + (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile) + 0))) + (changed ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds + + (do-cp (cond + ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover + (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile) + ;; TODO: Need to fix this for WAL mod. Can't just copy. + (system (conc "/bin/mkdir -p " dest-directory)) + (system (conc "/bin/cp " srcfile " " destfile)) + #t) + (changed ;; (and changed + #t) + ((and changed *time-to-exit*) ;; last sync + #t) + (else + #f)))) + (if (or dejunk do-cp) + (let* ((start-time (current-milliseconds)) + ;; subdb is misnamed - should be dbdat (I think...) + (subdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc)) + ;; (or (dbfile:get-subdb dbstruct run-id) + ;; (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc))) + (mtdb (dbr:subdb-mtdbdat subdb)) + ;; + ;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .megatest/.db + ;; + (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc))) + + (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds") + (if old2new + (begin + (if dejunk (db:clean-up run-id mtdb)) + (db:sync-tables (db:sync-all-tables-list + dbstruct + (db:get-keys dbstruct)) + #f mtdb tmpdb)) + (begin + (if dejunk (db:clean-up run-id tmpdb)) + (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f tmpdb mtdb))) + (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time))) + (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date")))) + dbfiles)) + data-synced)) ;; Sync all changed db's ;; (define (db:tmp->megatest.db-sync dbstruct run-id last-update) (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -224,14 +224,17 @@ (define (dbfile:set-subdb dbstruct run-id subdb) (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb)) ;; (define *dbfile:num-handles-in-use* 0) -;; Get/open a database +;; Get/open a database. +;; +;; NOTE: most usage should call dbfile:open-db to get a dbdat +;; ;; if run-id => get run specific db ;; if #f => get main db -;; if run-id is a string treat it as a filename +;; if run-id is a string treat it as a filename - DON'T use this - we'll get rid of it. ;; 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 (dbfile:get-dbdat dbstruct run-id)