Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -51,10 +51,11 @@ (define *configdat* #f) ;; megatest.config data (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done (define *toppath* #f) (define *already-seen-runconfig-info* #f) +(define *time-zero* (current-seconds)) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) @@ -387,21 +388,25 @@ (configf:lookup *configdat* "setup" "megatest-db")) ;; run-ids ;; if #f use *db-local-sync* : or 'local-sync-flags ;; if #t use timestamps : or 'timestamps -(define (common:sync-to-megatest.db run-ids) - (let ((start-time (current-seconds)) - (run-ids-to-process (if (list? run-ids) - run-ids - (if (or (eq? run-ids 'timestamps)(eq? run-ids #t)) - (db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db")) - (mtdb-exists (file-exists? mtdb-fpath))) - (if mtdb-exists - (file-modification-time mtdb-fpath) - 0))) - (hash-table-keys *db-local-sync*))))) +;; +(define (common:sync-to-megatest.db run-ids-in) + (let* ((start-time (current-seconds)) + (run-ids (if (hash-table-ref/default *db-local-sync* 'all #f) + 'timestamps + run-ids-in)) + (run-ids-to-process (if (list? run-ids) + run-ids + (if (or (eq? run-ids 'timestamps)(eq? run-ids #t)) + (db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db")) + (mtdb-exists (file-exists? mtdb-fpath))) + (if mtdb-exists + (file-modification-time mtdb-fpath) + 0))) + (hash-table-keys *db-local-sync*))))) (debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process) (for-each (lambda (run-id) (mutex-lock! *db-multi-sync-mutex*) (if (or run-ids ;; if we were provided with run-ids, proceed Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -316,11 +316,11 @@ ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) (dboard:tabdat-keys-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) - (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) + (dboard:tabdat-tot-runs-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-num-runs db:get-num-runs "%")) ) ;; RADT => Matrix defstruct addition (defstruct dboard:graph-dat ((id #f) : string) @@ -640,11 +640,11 @@ (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (rmt:get-key-vals run-id)) + (key-vals (db:dispatch-query (db:get-access-mode) rmt:get-key-vals db:get-key-vals run-id)) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) @@ -1020,11 +1020,11 @@ newval)))))) (define (dashboard:update-target-selector tabdat #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) (key-lbs (dboard:tabdat-key-listboxes tabdat)) - (db-target-dat (rmt:get-targets)) + (db-target-dat (db:dispatch-query (db:get-access-mode) rmt:get-targets db:get-targets)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (list->vector (take (append (string-split x "/") Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -343,43 +343,11 @@ (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; -(define *time-zero* (current-seconds)) -(define *watchdog* - (make-thread - (lambda () - (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (common:legacy-sync-required)) - (debug-mode (debug:debug-mode 1)) - (last-time (current-seconds))) - (if (common:legacy-sync-recommended) - (let loop () - ;; sync for filesystem local db writes - ;; - (let ((start-time (current-seconds))) - (if legacy-sync (common:sync-to-megatest.db #f)) - (if (and debug-mode - (> (- start-time last-time) 60)) - (begin - (set! last-time start-time) - (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) - - ;; keep going unless time to exit - ;; - (if (not *time-to-exit*) - (let delay-loop ((count 0)) - (if (and (not *time-to-exit*) - (< count 11)) ;; aprox 5-6 seconds - (begin - (thread-sleep! 1) - (delay-loop (+ count 1)))) - (loop))) - (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) - "Watchdog thread"))) +(define *watchdog* (make-thread common:watchdog "Watchdog thread")) (thread-start! *watchdog*) (if (args:get-arg "-log")