Index: api-inc.scm ================================================================== --- api-inc.scm +++ api-inc.scm @@ -72,11 +72,11 @@ read-test-data* login tasks-get-last testmeta-get-record have-incompletes? - synchash-get + ;; synchash-get get-changed-record-ids get-run-record-ids get-not-completed-cnt)) (define api:write-queries @@ -275,11 +275,11 @@ ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) + ;; ((synchash-get) (apply synchash:server-get dbstruct params)) ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) ((get-test-times) (apply db:get-test-times dbstruct params)) ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) Index: common-inc.scm ================================================================== --- common-inc.scm +++ common-inc.scm @@ -871,11 +871,11 @@ *db-cache-path* (if *toppath* ;; common:get-create-writeable-dir (handle-exceptions exn (begin - (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) + (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*) (exit 1)) (let ((dbpath (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/megatest_localdb/" (common:get-testsuite-name) "/" Index: configf-inc.scm ================================================================== --- configf-inc.scm +++ configf-inc.scm @@ -649,11 +649,11 @@ (set! new hed) ;; will append this at the bottom of the loop (set! secname section-name) )) ;; No need to process key cmd, let it fall though to key val (configf:key-val-pr ( x key val ) - (let ((newval (config-lookup indat section-name key))) ;; was sec, bug or correct? + (let ((newval (config-lookup indat secname key))) ;; was sec, bug or correct? ;; can handle newval == #f here => that means key is removed (cond ((equal? newval val) (set! res (append res (list hed)))) ((not newval) ;; key has been removed Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -2423,59 +2423,16 @@ (iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0) -(define (dashboard:recalc modtime please-update-buttons last-db-update-time) - (or please-update-buttons - (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific - (> modtime (- last-db-update-time 3)) ;; add three seconds of margin - (> (current-seconds)(+ last-db-update-time 1))))) - ;; (define *monitor-db-path* #f) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. ;; (tasks:open-db) -(define (dashboard:get-youngest-run-db-mod-time dbdir) - (handle-exceptions - exn - (begin - (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir) - (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (common:max (map (lambda (filen) - (file-modification-time filen)) - (glob (conc dbdir "/*.db*")))))) - -(define (dboard:get-last-db-update tabdat context) - (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) - -(define (dboard:set-last-db-update! tabdat context newtime) - (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) - -;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db -;; is closed (I think). If db dir starts with /tmp always return true -;; -(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) - (let* ((run-update-time (current-seconds)) - (dbdir (dboard:tabdat-dbdir tabdat)) - (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) - (recalc (dashboard:recalc modtime - (dboard:commondat-please-update commondat) - (dboard:get-last-db-update tabdat context-key)))) - ;; (dboard:tabdat-last-db-update tabdat)))) - (if recalc - (dboard:set-last-db-update! tabdat context-key run-update-time)) - (dboard:commondat-please-update-set! commondat #f) - recalc)) - -;; point inside line -;; -(define-inline (dashboard:px-between px lx1 lx2) - (and (< lx1 px)(> lx2 px))) - ;;Not reference anywhere ;; ;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing ;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) ;; Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -76,14 +76,14 @@ ;; (dbr:dbstruct-locdbs-set! v (make-hash-table)) ;; v)) ;; Returns the database for a particular run-id fron the dbstruct:localdbs ;; -(define (dbr:dbstruct-localdb v run-id) +#;(define (dbr:dbstruct-localdb v run-id) (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f)) -(define (dbr:dbstruct-localdb-set! v run-id db) +#;(define (dbr:dbstruct-localdb-set! v run-id db) (hash-table-set! (dbr:dbstruct-locdbs v) run-id db)) (define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) Index: dcommon-inc.scm ================================================================== --- dcommon-inc.scm +++ dcommon-inc.scm @@ -127,11 +127,11 @@ ;; (define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed) (let ((curr-val (iup:attribute mtrx cell-name))) (if (not (equal? curr-val new-val)) (begin - (iup:attribute-set! mtrx cell-name col-name) + (iup:attribute-set! mtrx cell-name new-val) ;; was col-name #t) ;; need a re-draw prev-changed))) ;; TO-DO @@ -1390,6 +1390,49 @@ (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case (begin (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) #t) #f))) + +;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db +;; is closed (I think). If db dir starts with /tmp always return true +;; +(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) + (let* ((run-update-time (current-seconds)) + (dbdir (dboard:tabdat-dbdir tabdat)) + (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) + (recalc (dashboard:recalc modtime + (dboard:commondat-please-update commondat) + (dboard:get-last-db-update tabdat context-key)))) + ;; (dboard:tabdat-last-db-update tabdat)))) + (if recalc + (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) + +(define (dashboard:get-youngest-run-db-mod-time dbdir) + (handle-exceptions + exn + (begin + (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (common:max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc dbdir "/*.db*")))))) + +(define (dboard:get-last-db-update tabdat context) + (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) + +(define (dboard:set-last-db-update! tabdat context newtime) + (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) + +;; point inside line +;; +(define-inline (dashboard:px-between px lx1 lx2) + (and (< lx1 px)(> lx2 px))) + +(define (dashboard:recalc modtime please-update-buttons last-db-update-time) + (or please-update-buttons + (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific + (> modtime (- last-db-update-time 3)) ;; add three seconds of margin + (> (current-seconds)(+ last-db-update-time 1))))) Index: megamod.scm ================================================================== --- megamod.scm +++ megamod.scm @@ -145,10 +145,11 @@ (include "megatest-version.scm") ;; globals (define *writes-total-delay* 0) (define *exit-started* #f) +(define *last-monitor-update-time* 0) (define *tim* (iup:timer)) ;; The watchdog is to keep an eye on things like db sync etc. ;; Index: rmt-inc.scm ================================================================== --- rmt-inc.scm +++ rmt-inc.scm @@ -515,11 +515,11 @@ #f))) (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) -#;(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) +(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area (rmt:test-get-rundir-from-test-id run-id test-id)))) (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) Index: tdb-inc.scm ================================================================== --- tdb-inc.scm +++ tdb-inc.scm @@ -57,13 +57,13 @@ dbexists) (sqlite3:open-database dbpath) (sqlite3:open-database ":memory:")))) (tdb-writeable (and (file-write-access? work-area) (file-write-access? dbpath))) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) + (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") + (string->number (args:get-arg "-override-timeout")) + 136000)))) (if (and tdb-writeable *db-write-access*) (sqlite3:set-busy-handler! db handler)) (if (not dbexists)