Overview
| Comment: | Remove *db-keys* as global. Fixed typo in common:simple-setup Changed hh:get to hh:get-value and hh:get-subhash Ripped out guts of Run Areas (derived from Run Summary) and put in some stubs. Primed dashboard.scm to use areas based dbstucts. The rmt: calls have not being eliminated yet. Disabled ro db handling in dashboard. Added tab for pivot controls. Added couple missing bits for the db:dashboard-open-db multi-area support. Tested and working now. |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.64-areas-dashboard |
| Files: | files | file ages | folders |
| SHA1: |
9b83825da52aa91df4c199ee5d43fcd0 |
| User & Date: | matt on 2017-08-13 23:07:18 |
| Other Links: | branch diff | manifest | tags |
Context
|
2017-11-16
| ||
| 16:21 | Deconstructing changes make for areas-dashboard to isolate catastrophic bug in fixme-matt Closed-Leaf check-in: 436bc0ac0f user: mrwellan tags: v1.64-areas-dashboard-bug-fix | |
|
2017-08-14
| ||
| 01:03 | Partially removed global *db-cache-path* (might need to add it back for performance reasons, used in rmt: calls.) Modified common:get-db-tmp-area to get info from dbstruct instead of globals. Added proc to open area dbs Gutted dboard:areas-update-tree. Does only areas now. First pass on some refactoring in db:get-db, db:open-db, db:dbfile-path (these need to be reduced to one function). check-in: 37c6122258 user: matt tags: v1.64-areas-dashboard, fixme-matt | |
|
2017-08-13
| ||
| 23:07 | Remove *db-keys* as global. Fixed typo in common:simple-setup Changed hh:get to hh:get-value and hh:get-subhash Ripped out guts of Run Areas (derived from Run Summary) and put in some stubs. Primed dashboard.scm to use areas based dbstucts. The rmt: calls have not being eliminated yet. Disabled ro db handling in dashboard. Added tab for pivot controls. Added couple missing bits for the db:dashboard-open-db multi-area support. Tested and working now. check-in: 9b83825da5 user: matt tags: v1.64-areas-dashboard | |
|
2017-08-09
| ||
| 23:24 | Completed generalized open db proc given area. check-in: 79525ab1fe user: matt tags: v1.64-areas-dashboard | |
Changes
Modified common.scm from [bc7da1c8f9] to [261f9da290].
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
;; res))))
;; A hash table that can be accessed by #{scheme ...} calls in
;; config files. Allows communicating between confgs
;;
(define *user-hash-data* (make-hash-table))
| | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
;; res))))
;; 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 *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
(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
|
| ︙ | ︙ | |||
1129 1130 1131 1132 1133 1134 1135 |
mtconfigf
;; environ-patt: "env-override"
given-toppath: toppath
;; pathenvvar: "MT_RUN_AREA_HOME"
))
(mtconf (if mtconfdat (car mtconfdat) #f)))
(if mtconf
| | | 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 |
mtconfigf
;; environ-patt: "env-override"
given-toppath: toppath
;; pathenvvar: "MT_RUN_AREA_HOME"
))
(mtconf (if mtconfdat (car mtconfdat) #f)))
(if mtconf
(configf:section-var-set! mtconf "dyndat" "toppath" toppath))
mtconfdat))
;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
(let ((res #t)) ;; priority by order of evaluation
(if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files!
|
| ︙ | ︙ | |||
2396 2397 2398 2399 2400 2401 2402 | (define-inline (hh:set-ht! hh ht) (vector-set! hh 0 ht)) (define-inline (hh:get-ht hh) (vector-ref hh 0)) (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 ... ;; | | | > > > > > > > > > > > | > > > > > > > > | 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 |
(define-inline (hh:set-ht! hh ht) (vector-set! hh 0 ht))
(define-inline (hh:get-ht hh) (vector-ref hh 0))
(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-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-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
;;
(define (hh:set! hh value . keys)
(if (null? keys)
(hh:set-value! hh value) ;; we have reached the end of the line, store the value
(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 (not sub-hh) ;; we'll need to add the next level of hierarchy
(let ((new-sub-hh (hh:make-hh)))
(hash-table-set! sub-ht (car keys) new-sub-hh)
(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)
'())))
|
Modified dashboard-areas.scm from [686be016f0] to [e946817510].
1 2 3 4 5 | ;;====================================================================== ;; AREAS ;;====================================================================== (define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix) | > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | > | < | | | | | | | | | | | | | | | | | | | < | > | | | | | | | | < < < < < < < | > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
;;======================================================================
;; AREAS
;;======================================================================
(define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix)
;; 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
(lambda (obj lin col status)
|
| ︙ | ︙ | |||
181 182 183 184 185 186 187 | #:expand "YES" #:addexpanded "YES" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () ;; (print "obj: " obj ", id: " id ", state: " state) | > | > > > > > > > > > > > > > > > | | | | | | | | | | < > | | > > > > | | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
#:expand "YES"
#:addexpanded "YES"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
;; (print "obj: " obj ", id: " id ", state: " state)
(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)
(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)))
"dashboard:areas-summary-updater")
)
|
| ︙ | ︙ |
Modified dashboard.scm from [baf0a27cbf] to [136f08f6a7].
| ︙ | ︙ | |||
101 102 103 104 105 106 107 |
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
;; TODO: Move this inside (main)
;;
| | | | | | | | > > | > > | | | | | | < | < < < | < < < | < < > | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
;; TODO: Move this inside (main)
;;
;; (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))))
;; 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"))
;;(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)));;;)
;;)
;; data common to all tabs goes here
;;
(defstruct dboard:commondat
((curr-tab-num 0) : number)
please-update
(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
(dboard:commondat-curr-tab-num commondat)
0)) ;; tab-num value is curr-tab-num value in passed commondat
|
| ︙ | ︙ | |||
307 308 309 310 311 312 313 | ;; runs-summary tab state ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) ((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) | < | > | > > > | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
;; runs-summary tab state
((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
((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)
;; 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:
(cons dboard:tabdat?
(lambda (tabdat-item)
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 | (define (dboard:setup-tabdat tabdat) (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. | > | > | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
(define (dboard:setup-tabdat tabdat)
(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.
(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 "%"))
)
;; RADT => Matrix defstruct addition
|
| ︙ | ︙ | |||
2334 2335 2336 2337 2338 2339 2340 |
(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")))
(num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3)))))
(iup:vbox
| > > | | | | | | | | | | | | | | | > > > > > > > > > > > | 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 |
(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")))
(num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3)))))
(iup:vbox
(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
;; iup:hbox
;; (map
|
| ︙ | ︙ | |||
3574 3575 3576 3577 3578 3579 3580 | "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 |
"dashboard:runs-tab-updater"))
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
(define (main)
;; (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)
(>= 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))))
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
(if (args:get-arg "-repl")
(repl)
(main))
|
Modified db.scm from [ab18972644] to [ecd11e6ee3].
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
;; 2. get homehost
;; 3. create /tmp db area (if needed)
;; 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)
| | > | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
;; 2. get homehost
;; 3. create /tmp db area (if needed)
;; 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 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))))
;; sync all the areas listed in area-paths
;;
|
| ︙ | ︙ | |||
1999 2000 2001 2002 2003 2004 2005 | ;; re-read the db over and over again for the keys since they never ;; change ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) | > | | | 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 |
;; re-read the db over and over again for the keys since they never
;; change
;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?
(define (db:get-keys dbstruct)
(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;")))
(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))
#f
(let loop ((hed (car header))
|
| ︙ | ︙ |
Modified mrmt.scm from [3ceebb0592] to [c091af7199].
| ︙ | ︙ | |||
475 476 477 478 479 480 481 | ;; These require run-id because the values come from the run! ;; (define (mrmt:get-key-val-pairs run-id) (mrmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (mrmt:get-keys) | | | | | | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 |
;; These require run-id because the values come from the run!
;;
(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)) ;; )
(define (mrmt:get-keys-write) ;; dummy query to force server start
(let ((res (mrmt:send-receive 'get-keys-write #f '())))
;; (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
;;
(define (mrmt:get-key-vals run-id)
(or (hash-table-ref/default *keyvals* run-id #f)
|
| ︙ | ︙ |
Modified rmt.scm from [677a774188] to [8ae137f573].
| ︙ | ︙ | |||
475 476 477 478 479 480 481 | ;; These require run-id because the values come from the run! ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) | | | | | | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 |
;; These require run-id because the values come from the run!
;;
(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)) ;; )
(define (rmt:get-keys-write) ;; dummy query to force server start
(let ((res (rmt:send-receive 'get-keys-write #f '())))
;; (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
;;
(define (rmt:get-key-vals run-id)
(or (hash-table-ref/default *keyvals* run-id #f)
|
| ︙ | ︙ |