Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -195,10 +195,15 @@ ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ((tasks-get-last) (apply tasks:get-last dbstruct params)) + ;; NO SYNC DB + ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) + ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) + ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) + ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -110,10 +110,12 @@ (define *db-access-mutex* (make-mutex)) (define *db-transaction-mutex* (make-mutex)) (define *db-cache-path* #f) (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) +;; no sync db +(define *no-sync-db* #f) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold @@ -2062,21 +2064,25 @@ (number->string x 16)) (map string->number (string-split instr))) "/")) -(define (common:faux-lock keyname) - (if (rmt:get-var keyname) - #f +(define (common:faux-lock keyname #!key (wait-time 5)) + (if (rmt:no-sync-get/default keyname #f) + (if (> wait-time 0) + (begin + (thread-sleep! 1) + (common:faux-lock keyname wait-time: (- wait-time 1))) + #f) (begin - (rmt:set-var keyname (conc (current-process-id))) + (rmt:no-sync-set keyname (conc (current-process-id))) (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))))) (define (common:faux-unlock keyname #!key (force #f)) - (if (or force (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))) + (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))) (begin - (if (rmt:get-var keyname) (rmt:del-var keyname)) + (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) #t) #f)) (define (common:in-running-test?) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -708,11 +708,11 @@ #f)))) (common:faux-unlock fname) res) (begin - (debug:print 0 *default-log-port* "WARNING: could not get faux-lock on " fname) + (debug:print 0 *default-log-port* "WARNING: could not get lock on " fname) #f))) ;; convert hierarchial list to ini format ;; (define (configf:config->ini data) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1842,24 +1842,40 @@ (db (sqlite3:open-database dbname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") db)) + +;; if we are not a server create a db handle. this is not finalized +;; so watch for problems. I'm still not clear if it is needed to manually +;; finalize sqlite3 dbs with the sqlite3 egg. +;; +(define (db:no-sync-db db-in) + (if db-in + db-in + (let ((db (db:open-no-sync-db))) + (set! *no-sync-db* db) + db))) (define (db:no-sync-set db var val) - (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) + (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) + +(define (db:no-sync-del! db var) + (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var)) (define (db:no-sync-get/default db var default) (let ((res default)) (sqlite3:for-each-row (lambda (val) (set! res val)) - db + (db:no-sync-db db) "SELECT val FROM no_sync_metadat WHERE var=?;" var) (if res - (let ((newres (string->number res))) + (let ((newres (if (string? res) + (string->number res) + #f))) (if newres newres res)) res))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -849,10 +849,23 @@ (define (rmt:tasks-set-state-given-param-key param-key new-state) (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) (define (rmt:tasks-get-last target runname) (rmt:send-receive 'tasks-get-last #f (list target runname))) + +;;====================================================================== +;; N O S Y N C D B +;;====================================================================== + +(define (rmt:no-sync-set var val) + (rmt:send-receive 'no-sync-set #f `(,var ,val))) + +(define (rmt:no-sync-get/default var default) + (rmt:send-receive 'no-sync-get/default #f `(,var ,default))) + +(define (rmt:no-sync-del! var) + (rmt:send-receive 'no-sync-del! #f `(,var))) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -458,10 +458,11 @@ (let ((legacy-sync (common:run-sync?)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (no-sync-db (db:open-no-sync-db)) (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))) + (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls (debug:print-info 2 *default-log-port* "Periodic sync thread started.") (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) (let* (;;(dbstruct (db:setup)) (mtdb (dbr:dbstruct-mtdb dbstruct))