Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -209,12 +209,14 @@ (dbr:dbstruct-dbfname-set! dbstruct dbfname) (dbr:dbstruct-sync-proc-set! dbstruct (lambda (last-update) (if *sync-in-progress* (debug:print 3 *default-log-port* "WARNING: overlapping calls to sync to disk") - (let* ((sync-cmd (conc "megatest -db2db -from "tmpdb" -to "dbfullname"&")) + (let* ((syncer-logfile (conc areapath"/logs/"dbfname"-syncer.log")) + (sync-cmd (conc "NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "tmpdb" -to "dbfullname" -period 5 -timeout 10 &")) (synclock-file (conc dbfullname".lock")) + (syncer-running-file (conc dbfullname"-sync-running")) (synclock-mod-time (if (file-exists? synclock-file) (handle-exceptions exn #f (file-modification-time synclock-file)) @@ -223,11 +225,13 @@ (thread-start! (make-thread (lambda () (set! *sync-in-progress* #t) (debug:print-info "Running "sync-cmd) - (system sync-cmd) + (if (file-exists? syncer-running-file) + (debug:print-info 0 *default-log-port* "Syncer still running, skipping syncer start.") + (system sync-cmd)) (set! *sync-in-progress* #f))))))) (if (< (file-modification-time tmpdb) (file-modification-time dbfullname)) (debug:print 0 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname) (if synclock-mod-time Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -2571,43 +2571,53 @@ ;; (if (args:get-arg "-db2db") (let* ((duh (launch:setup)) (src-db (args:get-arg "-from")) (dest-db (args:get-arg "-to")) - (sync-period (args:get-arg "-period")) ;; NOT IMPLEMENTED YET - (sync-timeout (args:get-arg "-timeout")) ;; NOT IMPLEMENTED YET + (sync-period (args:get-arg-number "-period")) + (sync-timeout (args:get-arg-number "-timeout")) + ;; (sync-period (if sync-period-in (string->number sync-period-in) #f)) + ;; (sync-timeout (if sync-timeout-in (string->number sync-timeout-in) #f)) (lockfile (conc dest-db".sync-lock")) (keys (db:get-keys #f)) - ) - - (if (and src-db dest-db) - (if (file-exists? src-db) - (if (file-exists? lockfile) - (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...") - (dbfile:with-simple-file-lock - lockfile - (lambda () - ;;(with-output-to-file lockfile - ;; (lambda () - ;; (print (current-process-id)))) - (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...") - (if #f ;; (not (file-exists? dest-db)) - (begin - (dbfile:with-simple-file-lock - (conc dest-db ".lock") ;; is the db being opened right now? - (lambda () - (debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db) - (file-copy src-db dest-db)))) - (let ((res (dbmod:db-to-db-sync src-db dest-db 0 (dbfile:db-init-proc) keys))) - (if res - (debug:print-info 0 *default-log-port* "Synced " res " records from "src-db" to "dest-db) - (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue.")))) - ;; (delete-file* lockfile) - ))) - (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db)) - (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified")) - (set! *didsomething* #t))) + (thesync (lambda (last-update) + (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...") + (if (not (file-exists? dest-db)) + (begin + (dbfile:with-simple-file-lock + (conc dest-db ".lock") ;; is the db being opened right now? + (lambda () + (debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db) + (file-copy src-db dest-db) + 1))) + (let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys))) + (if res + (debug:print-info 0 *default-log-port* "Synced " res " records from "src-db" to "dest-db) + (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue.")) + res))))) + (if (and src-db dest-db) + (if (file-exists? src-db) + (if (file-exists? lockfile) + (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...") + (dbfile:with-simple-file-lock + (conc dest-db"-sync-running") + (lambda () + (let loop ((last-changed (current-seconds)) + (last-update 0)) + (let* ((changes (dbfile:with-simple-file-lock + lockfile + (lambda () + (thesync last-update)))) + (now-time (current-seconds))) + (if (and sync-period sync-timeout) ;; + (if (> sync-timeout (- now-time last-changed)) + (begin + (if sync-period (thread-sleep! sync-period)) + (loop (if (> changes 0) now-time last-changed) now-time))))))))) + (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db)) + (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified")) + (set! *didsomething* #t))) (if (args:get-arg "-list-test-time") (let* ((toppath (launch:setup))) (task:get-test-times) (set! *didsomething* #t))) Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -261,13 +261,13 @@ (servinf (tt-conn-servinf-file conn))) ;;(servinf (tt-servinf-file ttdat))) ;; (conc areapath"/.servinfo/"host":"port"-"pid":"dbfname))) ;; TODO, use (server:get-servinfo-dir areapath) (hash-table-set! (tt-conns ttdat) dbfname #f) (if (and servinf (file-exists? servinf)) (begin - (if (< attemptnum 3) + (if (< attemptnum 10) (begin - (thread-sleep! 0.25) + (thread-sleep! 0.5) (tt:handler ttdat cmd run-id params (+ attemptnum 1) area-dat areapath readonly-mode dbfname testsuite mtexe)) (begin (debug:print 0 *default-log-port* "INFO: no response from server "host":"port" for "dbfname) (if (and (file-exists? servinf) (> (- (current-seconds)(file-modification-time servinf)) 60))