| ︙ | | | ︙ | |
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
|
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
(use regex typed-records matchable)
(declare (unit dcommon))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses synchash))
(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
;; yes, this is non-ideal
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)
;;======================================================================
;; C O M M O N D A T A S T R U C T U R E
;;======================================================================
;;
;; data common to all tabs goes here
;;
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
>
>
|
>
>
>
>
|
<
>
>
>
>
>
>
|
|
|
|
|
|
|
>
>
>
>
|
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
|
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(declare (unit dcommon))
;; (declare (uses gutils))
(declare (uses dbmod))
(declare (uses mtver))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses mtargs))
(declare (uses testsmod))
(module dcommon
*
(import scheme
chicken.base
chicken.condition
chicken.string
chicken.pretty-print
chicken.sort
chicken.time
chicken.file
chicken.file.posix
chicken.port
chicken.process
chicken.process-context
chicken.process-context.posix)
(import srfi-18
format
iup
(prefix iup iup:)
canvas-draw
canvas-draw-iup
regex
typed-records
matchable
srfi-69
sparse-vectors
srfi-1
)
(import mtver
dbmod
commonmod
debugprint
configfmod
rmtmod
;; gutils
(prefix mtargs args:)
testsmod)
;; (include "megatest-version.scm")
(include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
;; (include "run_records.scm")
;; yes, this is non-ideal
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)
(define *last-monitor-update-time* 0)
(define *exit-started* #f)
;;======================================================================
;; C O M M O N D A T A S T R U C T U R E
;;======================================================================
;;
;; data common to all tabs goes here
;;
|
| ︙ | | | ︙ | |
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
key-vals
((last-update 0) : number) ;; last query to db got records from before last-update
((last-db-time 0) : number) ;; last timestamp on megatest.db
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
(db-path #f))
;;======================================================================
;; D O T F I L E
;;======================================================================
(define (dcommon:write-dotfile fname dat)
(with-output-to-file fname
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
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
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
|
key-vals
((last-update 0) : number) ;; last query to db got records from before last-update
((last-db-time 0) : number) ;; last timestamp on megatest.db
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
(db-path #f))
;; data for each specific tab goes here
;;
(defstruct dboard:tabdat
;; runs
((allruns '()) : list) ;; list of dboard:rundat records
((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
((done-runs '()) : list) ;; list of runs already drawn
((not-done-runs '()) : list) ;; list of runs not yet drawn
(header #f) ;; header for decoding the run records
(keys #f) ;; keys for this run (i.e. target components)
((numruns (string->number (or (args:get-arg "-cols")
(configf:lookup *configdat* "dashboard" "cols")
"8"))) : number) ;;
((tot-runs 0) : number)
((last-data-update 0) : number) ;; last time the data in allruns was updated
((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
(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
((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
((run-keys (make-hash-table)) : hash-table)
(runs-matrix #f) ;; used in newdashboard
((start-run-offset 0) : number) ;; left-right slider value
((start-test-offset 0) : number) ;; up-down slider value
((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
((all-test-names '()) : list)
;; Canvas and drawing data
(cnv #f)
(cnv-obj #f)
(drawing #f)
((run-start-row 0) : number)
((max-row 0) : number)
((running-layout #f) : boolean)
(originx #f)
(originy #f)
((layout-update-ok #t) : boolean)
((compact-layout #t) : boolean)
;; Run times layout
;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
(graph-matrix #f)
((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
((graph-matrix-row 1) : number)
((graph-matrix-col 1) : number)
;; Controls used to launch runs etc.
((command "") : string) ;; for run control this is the command being built up
(command-tb #f) ;; widget for the type of command; run, remove-runs etc.
(test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
(key-listboxes #f)
(key-lbs #f)
run-name ;; from run name setting widget
states ;; states for -state s1,s2 ...
statuses ;; statuses for -status s1,s2 ...
;; Selector variables
curr-run-id ;; current row to display in Run summary view
prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
((hide-empty-runs #f) : boolean)
((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
(hide-not-hide-button #f)
((searchpatts (make-hash-table)) : hash-table) ;;
((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
(target #f)
(test-patts #f)
;; db info to file the .db files for the area
(access-mode (db:get-access-mode)) ;; use cached db or not
(dbdir #f)
(dbfpath #f)
(dbkeys #f)
((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
(monitor-db-path #f) ;; where to find monitor.db
ro ;; is the database read-only?
;; tests data
((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
;; runs tree
((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
(runs-tree #f)
((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
;; tab data
((view-changed #t) : boolean)
((xadj 0) : number) ;; x slider number (if using canvas)
((yadj 0) : number) ;; y slider number (if using canvas)
;; 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)
;; runs summary view
tests-tree ;; used in newdashboard
)
;; additional setters for dboard:data
(define (dboard:tabdat-test-patts-set!-use vec val)
(dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
(define (dboard:tabdat-test-patts-use vec)
(let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?
;;======================================================================
;; D O T F I L E
;;======================================================================
(define (dcommon:write-dotfile fname dat)
(with-output-to-file fname
|
| ︙ | | | ︙ | |
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
(let ((curr-val (iup:attribute mtrx cell-name)))
(if (not (equal? curr-val new-val))
(begin
(iup:attribute-set! mtrx cell-name new-val) ;; was col-name
#t) ;; need a re-draw
prev-changed)))
;; TO-DO
;; 1. Make "data" hash-table hierarchial store of all displayed data
;; 2. Update synchash to understand "get-runs", "get-tests" etc.
;; 3. Add extraction of filters to synchash calls
;;
;; NOTE: Used in newdashboard
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
|
(let ((curr-val (iup:attribute mtrx cell-name)))
(if (not (equal? curr-val new-val))
(begin
(iup:attribute-set! mtrx cell-name new-val) ;; was col-name
#t) ;; need a re-draw
prev-changed)))
;; Display the tests as rows of boxes on the test/task pane
;;
(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records)
(canvas-clear! cnv)
(canvas-font-set! cnv "Helvetica, -10")
(let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
((originx originy) (canvas-origin cnv)))
;; (print "originx: " originx " originy: " originy)
;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
(if (hash-table-ref/default tests-draw-state 'first-time #t)
(begin
(hash-table-set! tests-draw-state 'first-time #f)
(hash-table-set! tests-draw-state 'scalef 1)
(hash-table-set! tests-draw-state 'tests-info (make-hash-table))
(hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
;; set these
(dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
(dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
))
;; TO-DO
;; 1. Make "data" hash-table hierarchial store of all displayed data
;; 2. Update synchash to understand "get-runs", "get-tests" etc.
;; 3. Add extraction of filters to synchash calls
;;
;; NOTE: Used in newdashboard
|
| ︙ | | | ︙ | |
673
674
675
676
677
678
679
680
681
682
683
684
685
686
|
(if (not (equal? (iup:attribute stats-matrix key) value))
(begin
(set! changed #t)
(iup:attribute-set! stats-matrix key value)))))
run-stats)
(if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))))
(define (dcommon:run-stats commondat tabdat #!key (tab-num #f))
(let* ((stats-matrix (iup:matrix expand: "YES"))
(stats-updater (lambda ()
(dcommon:stats-updater commondat tabdat stats-matrix))))
;; (dboard:commondat-please-update-set! commondat #t) ;; force redraw on first pass
;; (mark-for-update tabdat)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
|
(if (not (equal? (iup:attribute stats-matrix key) value))
(begin
(set! changed #t)
(iup:attribute-set! stats-matrix key value)))))
run-stats)
(if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))))
;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
;; adds the updater passed in the updaters list at that hashkey
;;
(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
(let* ((tnum (or tab-num
(dboard:commondat-curr-tab-num commondat)))
(curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
(hash-table-set! (dboard:commondat-updaters commondat)
tnum
(cons updater curr-updaters))))
;; ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
;; ;; adds the updater passed in the updaters list at that hashkey
;; ;;
;; (define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
;; (let* ((tnum (or tab-num
;; (dboard:commondat-curr-tab-num commondat)))
;; (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
;; (hash-table-set! (dboard:commondat-updaters commondat)
;; tnum
;; (cons updater curr-updaters))))
;;
(define (dcommon:run-stats commondat tabdat #!key (tab-num #f))
(let* ((stats-matrix (iup:matrix expand: "YES"))
(stats-updater (lambda ()
(dcommon:stats-updater commondat tabdat stats-matrix))))
;; (dboard:commondat-please-update-set! commondat #t) ;; force redraw on first pass
;; (mark-for-update tabdat)
|
| ︙ | | | ︙ | |
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
|
tb)
(iup:button "Execute" #:size "50x"
#:action (lambda (obj)
;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
(common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE")))))))
;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
;; (system cmd)))))))
(define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f))
(iup:frame
#:title "Set the action to take"
(iup:hbox
;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER")
(let* ((cmds-list '("run" "remove-runs")) ;; "set-state-status" "lock-runs" "unlock-runs"))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
|
tb)
(iup:button "Execute" #:size "50x"
#:action (lambda (obj)
;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
(common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE")))))))
;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
;; (system cmd)))))))
;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
;;
(define (dashboard:update-run-command tabdat)
(let* ((cmd-tb (dboard:tabdat-command-tb tabdat))
(cmd (dboard:tabdat-command tabdat))
(test-patt (let ((tp (dboard:tabdat-test-patts tabdat)))
(if (or (not tp)
(equal? tp ""))
"%"
tp)))
(states (dboard:tabdat-states tabdat))
(statuses (dboard:tabdat-statuses tabdat))
(target (let ((targ-list (dboard:tabdat-target tabdat)))
(if targ-list (string-intersperse targ-list "/") "no-target-selected")))
(run-name (dboard:tabdat-run-name tabdat))
(states-str (if (or (not states)
(null? states))
""
(conc " -state " (string-intersperse states ","))))
(statuses-str (if (or (not statuses)
(null? statuses))
""
(conc " -status " (string-intersperse statuses ","))))
(full-cmd "megatest"))
(case (string->symbol cmd)
((run)
(set! full-cmd (conc full-cmd
" -run"
" -testpatt "
test-patt
" -target "
target
" -runname "
run-name
" -clean-cache"
)))
((remove-runs)
(set! full-cmd (conc full-cmd
" -remove-runs -runname "
run-name
" -target "
target
" -testpatt "
test-patt
states-str
statuses-str
)))
(else (set! full-cmd " no valid command ")))
(iup:attribute-set! cmd-tb "VALUE" full-cmd)))
(define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f))
(iup:frame
#:title "Set the action to take"
(iup:hbox
;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER")
(let* ((cmds-list '("run" "remove-runs")) ;; "set-state-status" "lock-runs" "unlock-runs"))
|
| ︙ | | | ︙ | |
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
|
(if htmlviewercmd
(system (conc "(" htmlviewercmd " " lfilename " ) &"))
(iup:send-url lfilename))))
(define (dashboard:monitor-changed? commondat tabdat)
(let* ((run-update-time (current-seconds))
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path))
(file-modification-time monitor-db-path)
-1)))
(if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
(or (> monitor-modtime *last-monitor-update-time*)
(> (- 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)
|
|
|
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
|
(if htmlviewercmd
(system (conc "(" htmlviewercmd " " lfilename " ) &"))
(iup:send-url lfilename))))
(define (dashboard:monitor-changed? commondat tabdat)
(let* ((run-update-time (current-seconds))
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path))
(file-modification-time monitor-db-path)
-1)))
(if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
(or (> monitor-modtime *last-monitor-update-time*)
(> (- 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)
|
| ︙ | | | ︙ | |
1456
1457
1458
1459
1460
1461
1462
|
(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)))))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
|
(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)))))
;;======================================================================
;; stuff from gutils
;;
(define (iuplistbox-fill-list lb items #!key (selected-item #f))
(let ((i 1))
(for-each (lambda (item)
(iup:attribute-set! lb (number->string i) item)
(if selected-item
(if (equal? selected-item item)
(iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
(set! i (+ i 1)))
items)
;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
i))
(define (message-window msg)
(iup:show
(iup:dialog
(iup:vbox
(iup:label msg #:margin "40x40")))))
;; NOTE: These functions will move to iuputils
(define (gutils:colors-similar? color1 color2)
(let* ((c1 (map string->number (string-split color1)))
(c2 (map string->number (string-split color2)))
(delta (map (lambda (a b)(abs (- a b))) c1 c2)))
(null? (filter (lambda (x)(> x 3)) delta))))
(define gutils:colors
'((PASS . "70 249 73")
(FAIL . "253 33 49")
(SKIP . "230 230 0")))
(define (gutils:get-color-spec effective-state)
(or (alist-ref effective-state gutils:colors)
(alist-ref 'FAIL gutils:colors)))
;; BBnote - state status dashboard button color / text defined here
(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
;; ((if get-label cadr car)
(case (string->symbol state)
((COMPLETED) ;; ARCHIVED)
(case (string->symbol status)
((PASS) (list "70 249 73" status))
((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status))
((WARN WAIVED) (list "255 172 13" status))
((SKIP) (list (gutils:get-color-spec 'SKIP) status))
((ABORT) (list "198 36 166" status))
(else (list "253 33 49" status))))
((ARCHIVED)
(case (string->symbol status)
((PASS) (list "70 170 73" status))
((WARN WAIVED) (list "200 130 13" status))
((SKIP) (list (gutils:get-color-spec 'SKIP) status))
(else (list "180 33 49" status))))
;; (if (equal? status "PASS")
;; '("70 249 73" "PASS")
;; (if (or (equal? status "WARN")
;; (equal? status "WAIVED"))
;; (list "255 172 13" status)
;; (list "223 33 49" status)))) ;; greenish orangeish redish
((LAUNCHED) (list "101 123 142" state))
((CHECK) (list "255 100 50" state))
((REMOTEHOSTSTART) (list "50 130 195" state))
((RUNNING STARTED) (list "9 131 232" state))
((KILLREQ) (list "39 82 206" state))
((KILLED) (list "234 101 17" state))
((NOT_STARTED) (case (string->symbol status)
((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state))
(else (list "240 240 240" state))))
;; for xor mode below
;;
((CLEAN)
(case (string->symbol status)
((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these
(else (list "60 235 63" status))))
((DIRTY-BETTER) (list "160 255 153" status))
((DIRTY-WORSE) (list "165 42 42" status))
((BOTH-BAD) (list "180 33 49" status))
(else (list
;; "192 192 192"
"222 222 221"
state))))
;; end of stuff from gutils
)
|