@@ -99,19 +99,30 @@ (exit 1))) ;; data common to all tabs goes here ;; (defstruct dboard:commondat - ((curr-tab-num 0) : number) - ((tabdats (make-hash-table)) : hash-table) - ;; ((update-mutex (make-mutex)) : mutex) - (update-mutex (make-mutex)) - ((updaters (make-hash-table)) : hash-table) - ((updating #f) : boolean) + curr-tab-num + please-update + tabdats + update-mutex + updaters + updating uidat ;; needs to move to tabdat at some time - ((hide-not-hide-tabs #f) : boolean) + hide-not-hide-tabs ) + +(define (dboard:commondat-make) + (make-dboard:commondat + curr-tab-num: 0 + tabdats: (make-hash-table) + please-update: #t + update-mutex: (make-mutex) + updaters: (make-hash-table) + updating: #f + hide-not-hide-tabs: #f + )) (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) (hash-table-ref/default (dboard:commondat-tabdats commondat) (or tab-num (dboard:commondat-curr-tab-num commondat)) @@ -160,12 +171,11 @@ ((numruns (string->number (or (args:get-arg "-cols") "8"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id - ((please-update #t) : boolean) ;; was in commondat. - (last-test-dat #f) ;; cache last tests dat + ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files ;; Runs view ((buttondat (make-hash-table)) : hash-table) ;; ((item-test-names '()) : list) ;; list of itemized tests @@ -460,11 +470,11 @@ ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((num-to-get 100) + (let* ((num-to-get 20) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) @@ -907,16 +917,13 @@ (define (update-search commondat tabdat x val) (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) (dboard:tabdat-filters-changed-set! tabdat #t) (set-bg-on-filter commondat tabdat)) -(define (mark-for-update update-mutex tabdat) - (mutex-lock! update-mutex) +(define (mark-for-update tabdat) (dboard:tabdat-filters-changed-set! tabdat #t) - (dboard:tabdat-last-db-update-set! tabdat 0) - (dboard:tabdat-please-update-set! tabdat #t) - (mutex-unlock! update-mutex)) + (dboard:tabdat-last-db-update-set! tabdat 0)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -1208,12 +1215,11 @@ ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) (define (dboard:runs-tree-browser commondat tabdat) - (let* ((update-mutex (dboard:commondat-update-mutex commondat)) - (tb (iup:treebox + (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb @@ -1220,15 +1226,15 @@ (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id tabdat (cdr run-path)))) - (dboard:tabdat-target-set! tabdat (cdr run-path)) + ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number + (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path) (dboard:tabdat-layout-update-ok-set! tabdat #f) (if (number? run-id) (begin - (mark-for-update update-mutex tabdat) (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-view-changed-set! tabdat #t)) (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) @@ -1378,12 +1384,10 @@ (let ((res (assoc name lst))) (if (and res (> (length res) 1)) (cadr res) #f))) -;; generic update of tree with targets, runs -;; (define (dboard:update-tree tabdat runs-hash runs-header tb) (let* ((run-ids (sort (filter number? (hash-table-keys runs-hash)) (lambda (a b) (let* ((record-a (hash-table-ref runs-hash a)) (record-b (hash-table-ref runs-hash b)) @@ -1411,13 +1415,11 @@ userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids))) - -;; Updater for the run summary view -;; + (define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix) (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:tabdat-curr-run-id tabdat)) (last-update (hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0)) @@ -1426,14 +1428,14 @@ (db-pth (conc db-dir "/" run-id ".db"))) (hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth) db-pth))) (tests-dat (if (or (not run-id) (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps") - (dboard:tabdat-please-update tabdat) + (not (hash-table-exists? (dboard:tabdat-last-test-dat tabdat) run-id)) (>= (file-modification-time db-path) last-update)) (dboard:get-tests-dat tabdat run-id last-update) - (dboard:tabdat-last-test-dat tabdat))) + (hash-table-ref (dboard:tabdat-last-test-dat tabdat) run-id))) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) @@ -1445,11 +1447,11 @@ (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) ht))) - (dboard:tabdat-last-test-dat-set! tabdat tests-dat) + (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) (dboard:tabdat-filters-changed-set! tabdat #f) (let loop ((pass-num 0) (changed #f)) ;; Update the runs tree @@ -1580,11 +1582,10 @@ ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id tabdat (cdr run-path)))) (if (number? run-id) (begin - (mark-for-update update-mutex tabdat) (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-layout-update-ok-set! tabdat #f) ;; (dashboard:update-run-summary-tab) ) ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) @@ -1600,13 +1601,24 @@ (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) (system cmd))))) - (one-run-updater (lambda () - ;; (if (dashboard:database-changed? commondat tabdat) - (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))));; ) + (one-run-updater + (lambda () + (mutex-lock! update-mutex) + (when (not run-matrix) + (print "BB> What?? run-matrix is #f")) + (if (or (dashboard:database-changed? commondat tabdat) + (dboard:tabdat-view-changed tabdat)) + (debug:catch-and-dump + (lambda () ;; check that run-matrix is initialized before calling the updater + (if run-matrix + (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))) + "dashboard:one-run-updater") + ) + (mutex-unlock! update-mutex)))) (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split tb @@ -1616,12 +1628,11 @@ ;;====================================================================== ;; R U N S ;;====================================================================== (define (dboard:make-controls commondat tabdat) - (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat)) - (update-mutex (dboard:commondat-update-mutex commondat))) + (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat))) (iup:hbox (iup:vbox (iup:frame #:title "filter test and items" (iup:hbox @@ -1629,20 +1640,20 @@ (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" #:expand "NO" #:action (lambda (obj unk val) (debug:catch-and-dump (lambda () - (mark-for-update update-mutex tabdat) + (mark-for-update tabdat) (update-search commondat tabdat "test-name" val)) "make-controls"))) (iup:hbox (iup:button "Quit" #:action (lambda (obj) ;; (if (dboard:tabdat-dblocal tabdat) (db:close-all (dboard:tabdat-dblocal tabdat))) (exit)) #:expand "NO" #:size "40x15") (iup:button "Refresh" #:action (lambda (obj) - (mark-for-update update-mutex tabdat)) + (mark-for-update tabdat)) #:expand "NO" #:size "40x15") (iup:button "Collapse" #:action (lambda (obj) (debug:catch-and-dump (lambda () (let ((myname (iup:attribute obj "TITLE"))) @@ -1655,11 +1666,11 @@ (begin (for-each (lambda (tname) (hash-table-delete! *collapsed* tname)) (hash-table-keys *collapsed*)) (iup:attribute-set! obj "TITLE" "Collapse")))) - (mark-for-update update-mutex tabdat)) + (mark-for-update tabdat)) "make-controls collapse button")) #:expand "NO" #:size "40x15"))) (iup:vbox ;; (iup:button "Sort -t" #:action (lambda (obj) ;; (next-sort-option) @@ -1675,36 +1686,36 @@ (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL" #:size "80x15" #:dropdown "YES" #:action (lambda (obj val index lbstate) (set! *tests-sort-reverse* index) - (mark-for-update update-mutex tabdat)))) + (mark-for-update tabdat)))) (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) (set! hide-empty (iup:button "HideEmpty" ;; #:expand HORIZONTAL" #:expand "NO" #:size "80x15" #:action (lambda (obj) (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) - (mark-for-update update-mutex tabdat)))) + (mark-for-update tabdat)))) (set! hide (iup:button "Hide" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) (iup:attribute-set! hide "BGCOLOR" sel-color) (iup:attribute-set! show "BGCOLOR" nonsel-color) - (mark-for-update update-mutex tabdat)))) + (mark-for-update tabdat)))) (set! show (iup:button "Show" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) (iup:attribute-set! show "BGCOLOR" sel-color) (iup:attribute-set! hide "BGCOLOR" nonsel-color) - (mark-for-update update-mutex tabdat)))) + (mark-for-update tabdat)))) (iup:attribute-set! hide "BGCOLOR" sel-color) (iup:attribute-set! show "BGCOLOR" nonsel-color) ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... (iup:vbox (iup:hbox hide show) @@ -1718,11 +1729,11 @@ (map (lambda (status) (iup:toggle (conc status " ") #:fontsize btn-fontsz ;; "10" #:expand "HORIZONTAL" #:action (lambda (obj val) - (mark-for-update update-mutex tabdat) + (mark-for-update tabdat) (if (eq? val 1) (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) (set-bg-on-filter commondat tabdat)))) (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) @@ -1731,11 +1742,11 @@ (map (lambda (state) (iup:toggle (conc state " ") #:fontsize btn-fontsz #:expand "HORIZONTAL" #:action (lambda (obj val) - (mark-for-update update-mutex tabdat) + (mark-for-update tabdat) (if (eq? val 1) (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) (set-bg-on-filter commondat tabdat)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) @@ -1742,11 +1753,11 @@ (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns (dboard:tabdat-tot-runs tabdat))) (dboard:tabdat-start-run-offset-set! tabdat val) - (mark-for-update update-mutex tabdat) + (mark-for-update tabdat) (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" #:max (* 10 (length (dboard:tabdat-allruns tabdat))) #:min 0 @@ -1863,12 +1874,11 @@ (bdylst '()) (result '()) (i 0) (btn-height (dboard:tabdat-runs-btn-height runs-dat)) (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) - (cell-width (dboard:tabdat-runs-cell-width runs-dat)) - (update-mutex (dboard:commondat-update-mutex commondat))) + (cell-width (dboard:tabdat-runs-cell-width runs-dat))) ;; controls (along bottom) ;; (set! controls (dboard:make-controls commondat runs-dat)) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox @@ -1877,11 +1887,11 @@ (map (lambda (x) (let ((res (iup:hbox #:expand "HORIZONTAL" (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL") (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL" #:action (lambda (obj unk val) - (mark-for-update update-mutex runs-dat) + (mark-for-update runs-dat) (update-search commondat runs-dat x val)))))) (set! i (+ i 1)) res)) keynames))))) (let loop ((testnum 0) @@ -1892,11 +1902,11 @@ (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (string->number (iup:attribute obj "VALUE"))) (oldmax (string->number (iup:attribute obj "MAX"))) (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) - (mark-for-update update-mutex tabdat) + (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10)))) (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) )) @@ -1913,11 +1923,11 @@ ; #:impress img2 #:size (conc cell-width btn-height) #:expand "HORIZONTAL" #:fontsize btn-fontsz #:action (lambda (obj) - (mark-for-update update-mutex runs-dat) + (mark-for-update runs-dat) (toggle-hide testnum (dboard:commondat-uidat commondat)))))) ;; (iup:attribute obj "TITLE")))) (vector-set! lftcol testnum labl) (loop (+ testnum 1)(cons labl res)))))) ;; These are the headers for each row (let loop ((runnum 0) @@ -2019,11 +2029,11 @@ (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:tabdat-layout-update-ok-set! tabdat #f)) (dboard:commondat-curr-tab-num-set! commondat curr) (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (mark-for-update update-mutex tabdat) + (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) runs-view (dashboard:one-run commondat onerun-dat tab-num: 2) @@ -2110,21 +2120,19 @@ #f))) (define (dashboard:database-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!! - (recalc (dashboard:recalc modtime (dboard:tabdat-please-update tabdat) (dboard:tabdat-last-db-update tabdat)))) - (dboard:tabdat-please-update-set! tabdat #f) + (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat)))) + (dboard:commondat-please-update-set! commondat #f) recalc)) ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) (and (< lx1 px)(> lx2 px))) -(define (dashboard:summary-tab-updater commondat tab-num) - (if dashboard:update-summary-tab (dashboard:update-summary-tab))) ;; 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) ;; (define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) @@ -2760,11 +2768,11 @@ (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) (if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed)) - (let* ((commondat (make-dboard:commondat))) + (let* ((commondat (dboard:commondat-make))) ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) (if (> (length d) 1)