Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -99,11 +99,11 @@ ;; A hash table that can be accessed by #{scheme ...} calls in ;; config files. Allows communicating between confgs ;; (define *user-hash-data* (make-hash-table)) -(define *db-keys* #f) +;; (define *db-keys* #f) (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data (define *configdat* #f) ;; megatest.config data (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done @@ -1131,11 +1131,11 @@ given-toppath: toppath ;; pathenvvar: "MT_RUN_AREA_HOME" )) (mtconf (if mtconfdat (car mtconfdat) #f))) (if mtconf - (configf:section-var-set! mtconf "dyndat" "toppath" start-dir)) + (configf:section-var-set! mtconf "dyndat" "toppath" toppath)) mtconfdat)) ;; do we honor the caches of the config files? ;; (define (common:use-cache?) @@ -2398,18 +2398,29 @@ (define-inline (hh:set-value! hh value) (vector-set! hh 1 value)) (define-inline (hh:get-value hh value) (vector-ref hh 1)) ;; given a hierarchial hash and some keys look up the value ... ;; -(define (hh:get hh . keys) +(define (hh:get-value hh . keys) (if (null? keys) (vector-ref hh 1) ;; we have reached the end of the line, return the value sought (let ((sub-ht (hh:get-ht hh))) (if sub-ht ;; yes, there is more hierarchy (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) (if sub-hh - (apply hh:get sub-hh (cdr keys)) + (apply hh:get-value sub-hh (cdr keys)) + #f)) + #f)))) + +(define (hh:get-subhash hh . keys) + (if (null? keys) + (vector-ref hh 0) ;; we have reached the end of the line, return the value sought + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if sub-hh + (apply hh:get-subhash sub-hh (cdr keys)) #f)) #f)))) ;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value ;; @@ -2425,6 +2436,14 @@ (apply hh:set! new-sub-hh value (cdr keys))) (apply hh:set! sub-hh value (cdr keys)))) ;; call the sub-hierhash with remaining keys (begin (hh:set-ht! hh (make-hash-table)) (apply hh:set! hh value keys)))))) + +;; given a hierarchial hash and some keys, return the keys for that hash level +;; +(define (hh:get-keys hh . keys) + (let ((ht (apply hh:get-subhash hh keys))) + (if ht + (hash-table-keys ht) + '()))) Index: dashboard-areas.scm ================================================================== --- dashboard-areas.scm +++ dashboard-areas.scm @@ -1,118 +1,140 @@ ;;====================================================================== ;; AREAS ;;====================================================================== (define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix) - (dashboard:areas-do-update-rundat tabdat) ;; ) - (dboard:areas-summary-control-panel-updater tabdat) - (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (runs (vector-ref runs-dat 1)) - (run-id (dboard:tabdat-curr-run-id tabdat)) - (runs-hash (dashboard:areas-get-runs-hash tabdat)) - ;; (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)) - ;; runs) - ;; ht)) - ) - (if (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-tree) - (dboard:areas-update-tree tabdat runs-hash runs-header tb)) - (if run-id - (let* ((matrix-content - (case (dboard:tabdat-runs-summary-mode tabdat) - ((one-run) (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)) - ((xor-two-runs) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash)) - ((xor-two-runs-hide-clean) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) - (else (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash))))) - (when matrix-content - (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) - (row-indices (cadr indices)) - (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window - (numrows 1) - (numcols 1) - (changed #f) - ) - - (dboard:tabdat-filters-changed-set! tabdat #f) - (let loop ((pass-num 0) - (changed #f)) - (if (eq? pass-num 1) - (begin ;; big reset - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) - - (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) - (iup:attribute-set! run-matrix "NUMCOL" max-col )) - - (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) - (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) - (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name))))) - row-indices) - ;; (print "row-indices: " row-indices " col-indices: " col-indices) - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass - - ;; Cell contents - (for-each (lambda (entry) - ;; (print "entry: " entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (test-name row-name) ;; (list-ref valuedat 1)) - (item-path col-name) ;; (list-ref valuedat 2)) - (state (list-ref valuedat 1)) - (status (list-ref valuedat 2)) - (value (gutils:get-color-for-state-status state status)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (hash-table-set! cell-lookup key test-id) - (if (not (equal? (iup:attribute run-matrix key) (cadr value))) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key (cadr value)) - (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) - matrix-content) - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (if (<= num max-col) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) - col-indices) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to column labels changing - - ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) - ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) + ;; maps data from tabdat view-dat to the matrix + ;; if input databases have changed, refresh view-dat + ;; if filters have changed, refresh view-dat from input databases + ;; if pivots have changed, refresh view-dat from input databases + (let* ((runs-hash (dashboard:areas-get-runs-hash tabdat)) + (runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time")) + (tree-path (dboard:tabdat-tree-path tabdat))) + (dboard:areas-update-tree tabdat runs-hash runs-header tb) + (print "Tree path: " tree-path) + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") + + ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) + (iup:attribute-set! run-matrix "NUMCOL" 10) ;; max-col )) + + ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) + ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) + (iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row ))) + (iup:attribute-set! run-matrix "1:1" (conc tree-path)) + (iup:attribute-set! run-matrix "REDRAW" "ALL"))) + + ;; (dashboard:areas-do-update-rundat tabdat) ;; ) + ;; (dboard:areas-summary-control-panel-updater tabdat) + ;; (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + ;; (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + ;; (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + ;; (runs (vector-ref runs-dat 1)) + ;; (run-id (dboard:tabdat-curr-run-id tabdat)) + ;; (runs-hash (dashboard:areas-get-runs-hash tabdat)) + ;; ;; (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)) + ;; ;; runs) + ;; ;; ht)) + ;; ) + ;; (if (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-tree) + ;; (dboard:areas-update-tree tabdat runs-hash runs-header tb)) + ;; (if run-id + ;; (let* ((matrix-content + ;; (case (dboard:tabdat-runs-summary-mode tabdat) + ;; ((one-run) (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)) + ;; ((xor-two-runs) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash)) + ;; ((xor-two-runs-hide-clean) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) + ;; (else (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash))))) + ;; (when matrix-content + ;; (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) + ;; (row-indices (cadr indices)) + ;; (col-indices (car indices)) + ;; (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + ;; (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + ;; (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window + ;; (numrows 1) + ;; (numcols 1) + ;; (changed #f) + ;; ) + ;; + ;; (dboard:tabdat-filters-changed-set! tabdat #f) + ;; (let loop ((pass-num 0) + ;; (changed #f)) + ;; (if (eq? pass-num 1) + ;; (begin ;; big reset + ;; (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + ;; (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + ;; (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) + ;; + ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) + ;; (iup:attribute-set! run-matrix "NUMCOL" max-col )) + ;; + ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) + ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) + ;; (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) + ;; + ;; ;; Row labels + ;; (for-each (lambda (ind) + ;; (let* ((name (car ind)) + ;; (num (cadr ind)) + ;; (key (conc num ":0"))) + ;; (if (not (equal? (iup:attribute run-matrix key) name)) + ;; (begin + ;; (set! changed #t) + ;; (iup:attribute-set! run-matrix key name))))) + ;; row-indices) + ;; ;; (print "row-indices: " row-indices " col-indices: " col-indices) + ;; (if (and (eq? pass-num 0) changed) + ;; (loop 1 #t)) ;; force second pass + ;; + ;; ;; Cell contents + ;; (for-each (lambda (entry) + ;; ;; (print "entry: " entry) + ;; (let* ((row-name (cadr entry)) + ;; (col-name (car entry)) + ;; (valuedat (caddr entry)) + ;; (test-id (list-ref valuedat 0)) + ;; (test-name row-name) ;; (list-ref valuedat 1)) + ;; (item-path col-name) ;; (list-ref valuedat 2)) + ;; (state (list-ref valuedat 1)) + ;; (status (list-ref valuedat 2)) + ;; (value (gutils:get-color-for-state-status state status)) + ;; (row-num (cadr (assoc row-name row-indices))) + ;; (col-num (cadr (assoc col-name col-indices))) + ;; (key (conc row-num ":" col-num))) + ;; (hash-table-set! cell-lookup key test-id) + ;; (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + ;; (begin + ;; (set! changed #t) + ;; (iup:attribute-set! run-matrix key (cadr value)) + ;; (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + ;; matrix-content) + ;; + ;; ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + ;; + ;; (for-each (lambda (ind) + ;; (let* ((name (car ind)) + ;; (num (cadr ind)) + ;; (key (conc "0:" num))) + ;; (if (not (equal? (iup:attribute run-matrix key) name)) + ;; (begin + ;; (set! changed #t) + ;; (iup:attribute-set! run-matrix key name) + ;; (if (<= num max-col) + ;; (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) + ;; col-indices) + ;; + ;; (if (and (eq? pass-num 0) changed) + ;; (loop 1 #t)) ;; force second pass due to column labels changing + ;; + ;; ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) + ;; ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) + ;; (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) (define (dboard:areas-make-matrix commondat tabdat ) (iup:matrix #:expand "YES" #:click-cb @@ -183,32 +205,52 @@ #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () ;; (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 - (dboard:tabdat-prev-run-id-set! - tabdat - (dboard:tabdat-curr-run-id 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) - ))) + (let* ((prev-tree-path (dboard:tabdat-tree-path tabdat)) + (tree-path (tree:node->path obj id)) + ;; Need to get the path construction from the pivot data but for now assume: + ;; Area Target Runname + + + + + + ;;; ADD STUFF HERE .... + + + ) + (if (not (equal? prev-tree-path tree-path)) + (dboard:tabdat-view-changed tabdat)) + + (dboard:tabdat-tree-path-set! tabdat tree-path))) + ;; (run-id (tree-path->run-id tabdat (cdr run-path)))) + ;; (if (number? run-id) + ;; (begin + ;; (dboard:tabdat-prev-run-id-set! + ;; tabdat + ;; (dboard:tabdat-curr-run-id 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) + ;; ))) "selection-cb in areas-summary") ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (areas-matrix (dboard:areas-make-matrix commondat tabdat)) (areas-summary-updater (lambda () + ;; maps data from tabdat view-dat to the matrix + ;; if input databases have changed, refresh view-dat + ;; if filters have changed, refresh view-dat from input databases + ;; if pivots have changed, refresh view-dat from input databases (mutex-lock! update-mutex) - (if (or (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-updater) + (if (or ;; (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-updater) (dboard:tabdat-view-changed tabdat)) (debug:catch-and-dump (lambda () ;; check that areas-matrix is initialized before calling the updater (if areas-matrix (dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -103,32 +103,36 @@ (print help) (exit))) ;; TODO: Move this inside (main) ;; -(if (not (launch:setup)) - (begin - (print "Failed to find megatest.config, exiting") - (exit 1))) +;; (if (not (launch:setup)) +;; (begin +;; (print "Failed to find megatest.config, exiting") +;; (exit 1))) ;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature ;; first check for the switch ;; (if (or (args:get-arg "-rh5.11") (configf:lookup *configdat* "dashboard" "no-detachbox")) (set! iup:detachbox iup:vbox)) -(if (not (common:on-homehost?)) - (begin - (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) +;; (if (not (common:on-homehost?)) +;; (begin +;; (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) ;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") -(thread-start! (make-thread common:watchdog "Watchdog thread")) + + +;; (thread-start! (make-thread common:watchdog "Watchdog thread")) + + ;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") ;; (if (not (args:get-arg "-use-db-cache")) ;; (begin ;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") ;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) @@ -137,28 +141,20 @@ ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) please-update - tabdats - update-mutex - updaters - updating - uidat ;; needs to move to tabdat at some time - 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 - )) + (tabdats (make-hash-table)) + (update-mutex (make-mutex)) + (updaters (make-hash-table)) + (updating #f) + uidat ;; needs to move to tabdat at some time + (hide-not-hide-tabs #f) + (current-area-path #f) ;; the area of the path where the dashboard was started, if it is a megatest area + (areas (make-hash-table)) ;; area-name ==> area-path + (area-dbs #f) ;; use db:dashboard-open-db to add areas to the areas hash + ) ;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) ;; (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) (let* ((tnum (or tab-num @@ -309,13 +305,16 @@ ((runs-summary-mode-buttons '()) : list) ((runs-summary-mode 'one-run) : symbol) ((runs-summary-mode-change-callbacks '()) : list) (runs-summary-source-runname-label #f) (runs-summary-dest-runname-label #f) - ;; runs summary view - - tests-tree ;; used in newdashboard + + ;; Areas summary view + (tree-path '()) + (pivots #f) + (filters #f) + (view-dat (hh:make-hh)) ;; hierarchial hash of the data to view ) ;; register tabdat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle (hash-table-set! *BBpp_custom_expanders_list* TABDAT: @@ -348,11 +347,13 @@ (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) ;; HACK ALERT: this is a hack, please fix. - (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) + (if #f + (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) + (print "FIXME on line 350")) (dboard:tabdat-keys-set! tabdat (mrmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (mrmt:get-num-runs "%")) ) @@ -2336,25 +2337,38 @@ (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"))) (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3))))) (iup:vbox - (iup:hbox - (iup:frame - #:title "states" - (apply - iup:hbox - (map (lambda (colgrp) - (apply iup:vbox colgrp)) - (dboard:squarify state-toggles 3)))) - (iup:frame - #:title "statuses" - (apply - iup:hbox - (map (lambda (colgrp) - (apply iup:vbox colgrp)) - (dboard:squarify status-toggles 3))))) + + (let ((filter-pivot (iup:tabs + (iup:hbox + (iup:frame + #:title "states" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify state-toggles 3)))) + (iup:frame + #:title "statuses" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify status-toggles 3))))) + (iup:hbox + (iup:frame + #:title "Rows" + (iup:button "Rows pivot")) + (iup:frame + #:title "Cols" + (iup:button "Cols pivot")))))) + (iup:attribute-set! filter-pivot "TABTITLE0" "Filters") + (iup:attribute-set! filter-pivot "TABTITLE1" "Pivots ") + filter-pivot) + ;; ;; (iup:frame ;; #:title "state/status filter" ;; (iup:vbox ;; (apply @@ -3576,67 +3590,67 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) - (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; - (if (and (common:file-exists? mtdb-path) - (file-write-access? mtdb-path)) - (if (not (args:get-arg "-skip-version-check")) - (common:exit-on-version-changed))) - (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* ((areas (make-hash-table))) ;; mtdb-path (conc *toppath* "/megatest.db"))) ;; + ;; (if (and (common:file-exists? mtdb-path) + ;; (file-write-access? mtdb-path)) + ;; (if (not (args:get-arg "-skip-version-check")) + ;; (common:exit-on-version-changed))) + (let* ((commondat (make-dboard:commondat))) + ;; 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) - d - (list #f #f)))) - (run-id (car dat)) - (test-id (cadr dat))) - (if (and (number? run-id) - (number? test-id) + (if (> (length d) 1) + d + (list #f #f)))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) (>= test-id 0)) - (dashboard-tests:examine-test run-id test-id) - (begin - (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - ;; ((args:get-arg "-guimonitor") - ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) - (else - (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) - (dboard:commondat-curr-tab-num-set! commondat 0) - (dboard:commondat-add-updater - commondat - (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 1) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (time-obj) - (let ((update-is-running #f)) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (set! update-is-running (dboard:commondat-updating commondat)) - (if (not update-is-running) - (dboard:commondat-updating-set! commondat #t)) - (mutex-unlock! (dboard:commondat-update-mutex commondat)) - (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update - (begin - (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (dboard:commondat-updating-set! commondat #f) - (mutex-unlock! (dboard:commondat-update-mutex commondat))) - )) - 1)))) - - (let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab - ) "update buttons once")) - (th2 (make-thread iup:main-loop "Main loop"))) - (thread-start! th2) - (thread-join! th2))))) + (dashboard-tests:examine-test run-id test-id) + (begin + (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (exit 1))))) + ;; ((args:get-arg "-guimonitor") + ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) + (else + (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) + (dboard:commondat-curr-tab-num-set! commondat 0) + (dboard:commondat-add-updater + commondat + (lambda () + (dashboard:runs-tab-updater commondat 1)) + tab-num: 1) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (time-obj) + (let ((update-is-running #f)) + (mutex-lock! (dboard:commondat-update-mutex commondat)) + (set! update-is-running (dboard:commondat-updating commondat)) + (if (not update-is-running) + (dboard:commondat-updating-set! commondat #t)) + (mutex-unlock! (dboard:commondat-update-mutex commondat)) + (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update + (begin + (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) + (mutex-lock! (dboard:commondat-update-mutex commondat)) + (dboard:commondat-updating-set! commondat #f) + (mutex-unlock! (dboard:commondat-update-mutex commondat))) + )) + 1)))) + + (let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab + ) "update buttons once")) + (th2 (make-thread iup:main-loop "Main loop"))) + (thread-start! th2) + (thread-join! th2)))) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -90,18 +90,19 @@ ;; 4. sync data to /tmp db (or update if exists) ;; 5. return dbstruct (if (hash-table-exists? areas area-path) (hash-table-ref areas area-path) (if (common:file-exists? (conc area-path "/megatest.config") quiet-mode: #t) - (let* ((homehost (common:minimal-get-homehost toppath)) + (let* ((homehost (common:minimal-get-homehost area-path)) (on-hh (common:on-host? homehost)) (mtconfig (common:simple-setup area-path)) ;; returns ( configdat toppath configfile configf-name ) (dbstruct (make-dbr:dbstruct area-path: area-path homehost: homehost configdat: (car mtconfig))) (tmpdb (db:open-db dbstruct area-path: area-path do-sync: #t))) + (hash-table-set! areas area-path dbstruct) tmpdb) (begin (debug:print-info 0 *default-log-port* "attempt to open megatest.db in " area-path " but no megatest.config found.") #f)))) @@ -2001,20 +2002,21 @@ ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) - (if *db-keys* *db-keys* + (if (dbr:dbstruct-keys dbstruct) + (dbr:dbstruct-keys dbstruct) (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (key) (set! res (cons key res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) - (set! *db-keys* res) + (dbr:dbstruct-keys-set! dbstruct res) res))) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (or (null? header) (not row)) Index: mrmt.scm ================================================================== --- mrmt.scm +++ mrmt.scm @@ -477,18 +477,18 @@ ;; (define (mrmt:get-key-val-pairs run-id) (mrmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (mrmt:get-keys) - (if *db-keys* *db-keys* - (let ((res (mrmt:send-receive 'get-keys #f '()))) - (set! *db-keys* res) - res))) + ;; (if *db-keys* *db-keys* + (let ((res (mrmt:send-receive 'get-keys #f '()))) + ;; (set! *db-keys* res) + res)) ;; ) (define (mrmt:get-keys-write) ;; dummy query to force server start (let ((res (mrmt:send-receive 'get-keys-write #f '()))) - (set! *db-keys* res) + ;; (set! *db-keys* res) res)) ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe ;; to cache the resuls in a hash ;; Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -477,18 +477,18 @@ ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) - (if *db-keys* *db-keys* - (let ((res (rmt:send-receive 'get-keys #f '()))) - (set! *db-keys* res) - res))) + ;; (if *db-keys* *db-keys* + (let ((res (rmt:send-receive 'get-keys #f '()))) + ;; (set! *db-keys* res) + res)) ;; ) (define (rmt:get-keys-write) ;; dummy query to force server start (let ((res (rmt:send-receive 'get-keys-write #f '()))) - (set! *db-keys* res) + ;; (set! *db-keys* res) res)) ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe ;; to cache the resuls in a hash ;;