Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -275,10 +275,11 @@ "runname") #f)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir logfile) + (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (db:get-compressed-steps test-id work-area: rundir) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat (let ((tm (open-run-close db:testmeta-get-record #f testname))) @@ -310,12 +311,18 @@ (conc "-e " (get-environment-variable "SHELL")) ""))) (system (conc "cd " rundir ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) + (widgets (make-hash-table)) (refreshdat (lambda () - (let* ((curr-mod-time (file-modification-time db-path)) + (let* ((curr-mod-time (max (file-modification-time db-path) + (if (file-exists? testdat-path) + (file-modification-time testdat-path) + (begin + (set! testdat-path (conc rundir "/testdat.db")) + 0)))) (need-update (or (and (> curr-mod-time db-mod-time) (> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched request-update)) (newtestdat (if need-update (handle-exceptions @@ -328,14 +335,27 @@ (set! teststeps (db:get-compressed-steps test-id work-area: rundir)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) + (set! db-mod-time curr-mod-time) + (set! last-update (current-milliseconds)) + (set! request-update #f) ;; met the need ... ) (need-update ;; if this was true and yet there is no data .... - (db:test-set-testname! testdat "DEAD OR DELETED TEST")))))) - (widgets (make-hash-table)) + (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) + (if need-update + (begin + ;; update the gui elements here + (for-each + (lambda (key) + ;; (print "Updating " key) + ((hash-table-ref widgets key) testdat)) + (hash-table-keys widgets)) + (update-state-status-buttons testdat))) + ;; (iup:refresh self) + ))) (meta-widgets (make-hash-table)) (self #f) (store-label (lambda (name lbl cmd) (hash-table-set! widgets name (lambda (testdat) @@ -450,23 +470,45 @@ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) + (let ((max-row 0)) (if (not (null? teststeps)) (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) (colnum 1)) + (if (> rownum max-row)(set! max-row rownum)) (let ((val (vector-ref hed (- colnum 1))) (mtrx-rc (conc rownum ":" colnum))) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) (if (< colnum 6) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) - (loop (car tal)(cdr tal)(+ rownum 1) 1)))) - (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))) + (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) + (if (> max-row 0) + (begin + ;; we are going to speculatively clear rows until we find a row that is already cleared + (let loop ((rownum (+ max-row 1)) + (colnum 0) + (deleted #f)) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum) + (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) + (next-col (if (eq? colnum 6) 1 (+ colnum 1))) + (mtrx-rc (conc rownum ":" colnum)) + (curr-val (iup:attribute steps-matrix mtrx-rc))) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) + (if (and (string? curr-val) + (not (equal? curr-val ""))) + (begin + (iup:attribute-set! steps-matrix mtrx-rc "") + (loop next-row next-col #t)) + (if (eq? colnum 6) ;; not done, didn't get a full blank row + (if deleted (loop next-row next-col #f)) ;; exit on this not met + (loop next-row next-col deleted))))) + (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame @@ -512,16 +554,8 @@ (iup:callback-set! *tim* "ACTION_CB" (lambda (x) ;; Now start keeping the gui updated from the db (refreshdat) ;; update from the db here ;(thread-suspend! other-thread) - ;; update the gui elements here - (for-each - (lambda (key) - ;; (print "Updating " key) - ((hash-table-ref widgets key) testdat)) - (hash-table-keys widgets)) - (update-state-status-buttons testdat) - ; (iup:refresh self) (if *exit-started* (set! *exit-started* 'ok)))))))))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -118,14 +118,19 @@ (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) (define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%")) ;; (define *tot-run-count* (db:get-num-runs *db* "%")) + +;; Update management +;; (define *last-update* (current-seconds)) (define *last-db-update-time* 0) (define *please-update-buttons* #t) (define *delayed-update* 0) +(define *update-is-running* #f) +(define *update-mutex* (make-mutex)) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) (define *examine-test-dat* (make-hash-table)) @@ -1334,12 +1339,12 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== -;; ease debugging by loading ~/.megatestrc -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (cond ((args:get-arg "-run") @@ -1365,9 +1370,20 @@ (else (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) + (let ((update-is-running #f)) + (mutex-lock! *update-mutex*) + (set! update-is-running *update-is-running*) + (if (not update-is-running) + (set! *update-is-running* #t)) + (mutex-unlock! *update-mutex*) + (if (not update-is-running) + (begin (dashboard:run-update x) + (mutex-lock! *update-mutex*) + (set! *update-is-running* #f) + (mutex-unlock! *update-mutex*)))) 1)))) (iup:main-loop)