Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -29,12 +29,14 @@ (import scheme chicken data-structures extras + files (prefix sqlite3 sqlite3:) + matchable posix typed-records srfi-1 srfi-18 srfi-69 @@ -208,27 +210,27 @@ (debug:print 3 *default-log-port* "WARNING: overlapping calls to sync to disk") (begin (mutex-lock! *db-with-db-mutex*) ;; this mutex is used when overloaded or during a query that modifies the db (set! *sync-in-progress* #t) (dbmod:sync-gasket tables last-update inmem db - dbfullname syncdir) + dbfullname syncdir keys) (mutex-unlock! *db-with-db-mutex*) (thread-sleep! 0.5) ;; ensure at least 1/2 second down time between sync calls (set! *sync-in-progress* #f))))) ;; (dbmod:sync-tables tables #f db inmem) ;; (if db - (dbmod:sync-gasket tables #f inmem db dbfullname 'fromdest) ;; ) ;; load into inmem + (dbmod:sync-gasket tables #f inmem db dbfullname 'fromdest keys) ;; ) ;; load into inmem (dbr:dbstruct-last-update-set! dbstruct (current-seconds)) ;; should this be offset back in time by one second? dbstruct)) ;; (if (eq? syncdir 'todisk) ;; sync to disk normally, sync from in dashboard ;; (dbmod:sync-tables tables last-update inmem db) ;; (dbmod:sync-tables tables last-update db inmem)))) ;; direction: 'fromdest 'todest ;; -(define (dbmod:sync-gasket tables last-update inmem dbh dbfname direction) +(define (dbmod:sync-gasket tables last-update inmem dbh dbfname direction keys) (assert (sqlite3:database? inmem) "FATAL: sync-gasket: inmem is not a db") (assert (sqlite3:database? inmem) "FATAL: sync-gasket: dbh is not a db") (case (dbfile:sync-method) ((none) #f) ((attach) @@ -236,14 +238,14 @@ ((newsync) (dbmod:new-sync tables inmem dbh dbfname direction)) (else (case direction ((todisk) - (dbmod:sync-tables tables last-update inmem dbh) + (dbmod:sync-tables tables last-update keys inmem dbh) ) (else - (dbmod:sync-tables tables last-update dbh inmem)))))) + (dbmod:sync-tables tables last-update keys dbh inmem)))))) (define (dbmod:close-db dbstruct) ;; do final sync to disk file ;; (do-sync ...) (sqlite3:finalize! (dbr:dbstruct-ondiskdb dbstruct))) @@ -275,11 +277,11 @@ ;; then sync only records where field-name >= time-in-seconds ;; IFF field-name exists ;; ;; Use (db:sync-all-tables-list keys) to get the tbls input ;; -(define (dbmod:sync-tables tbls last-update fromdb todb) +(define (dbmod:sync-tables tbls last-update keys fromdb todb) (debug:print-info 0 *default-log-port* "dbmod:sync-tables called, from: "fromdb", to: "todb) (assert (sqlite3:database? fromdb) "FATAL: dbmod:sync-tables called with fromdb not a database" fromdb) (assert (sqlite3:database? todb) "FATAL: dbmod:sync-tables called with fromdb not a database" todb) (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) @@ -752,6 +754,41 @@ (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))) stmth3 run-id)))) (list incompleted oldlaunched toplevels))) +;;====================================================================== +;; db to db sync +;;====================================================================== + +(define (dbmod:db-to-db-sync src-db dest-db last-update init-proc keys) + (if (and (file-exists? src-db) ;; can't proceed without a source + (file-read-access? src-db)) + (let* ((have-dest (file-exists? dest-db)) + (dest-file-wr (and have-dest + (file-write-access? dest-db))) ;; exists and writable + (dest-dir (or (pathname-directory dest-db) + ".")) + (dest-dir-wr (and (file-exists? dest-dir) + (file-write-access? dest-dir))) + (d-wr (or (and have-dest + dest-file-wr) + dest-dir-wr)) + (copied (if (and (not have-dest) + dest-dir-wr) + (begin + (file-copy src-db dest-db) + #t) + #f))) + (if copied + (begin + (debug:print-info 0 *default-log-port* "db-to-db-sync done with file-copy") + #t) + (let* ((tables (db:sync-all-tables-list keys)) + (sdb (dbmod:safely-open-db src-db init-proc #t)) + (ddb (dbmod:safely-open-db dest-db init-proc d-wr)) + (res (dbmod:sync-gasket tables last-update sdb ddb dest-db 'todest keys))) + (sqlite3:finalize! sdb) + (sqlite3:finalize! ddb) + res))) + #f)) ) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -284,10 +284,11 @@ -list-test-time : list time requered to complete each test in a run. It following following arguments -runname -target -dumpmode -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and is $DISPLAY valid -list-waivers : dump waivers for specified target, runname, testpatt to stdout + -db2db : sync db to db, use -from, -to for dbs, -period and -timeout for continuous sync Diff report -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname and either -diff-email or -diff-html) -src-target @@ -333,11 +334,11 @@ ":status" "-status" "-list-runs" "-testdata-csv" "-testpatt" - "--modepatt" + ;; "--modepatt" "-modepatt" "-tagexpr" "-itempatt" "-setlog" "-set-toplog" @@ -346,10 +347,11 @@ "-m" "-rerun" "-days" "-rename-run" + "-from" "-to" "-dest" "-source" "-time-stamp" ;; values and messages @@ -378,10 +380,12 @@ "-envcap" "-envdelta" "-setvars" "-set-state-status" "-import-sexpr" + "-period" ;; sync period in seconds + "-timeout" ;; exit sync if timeout in seconds exceeded since last change ;; move runs stuff here "-remove-keep" "-set-run-status" "-age" @@ -495,10 +499,11 @@ "-convert-to-norm" "-convert-to-old" "-import-megatest.db" "-sync-to-megatest.db" + "-db2db" "-sync-brute-force" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only @@ -2560,10 +2565,33 @@ (if (args:get-arg "-sync-to") (let ((toppath (launch:setup))) (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) (set! *didsomething* #t))) +;; use with -from and -to +;; +(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 + (lockfile (conc dest-db".lock")) + (keys (db:get-keys #f)) + ) + + (if (and src-db dest-db) + (begin + (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...") + (let ((res (dbmod:db-to-db-sync src-db dest-db 0 (dbfile:db-init-proc) keys))) + (if res + (debug:print 0 *default-log-port* "Synced " res " records from "src-db" to "dest-db) + (debug:print 0 *default-log-port* "No sync due to permissions or non-existant source db.")))) + (debug:print 0 *default-log-port* "Skipping sync, there is a sync in progress.")) + (set! *didsomething* #t)) + (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified")) + (if (args:get-arg "-list-test-time") (let* ((toppath (launch:setup))) (task:get-test-times) (set! *didsomething* #t)))