| ︙ | | |
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
|
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
143
144
145
146
147
148
149
150
151
152
153
154
155
|
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
;; create a stuct for all the miscellaneous state
;;
(defstruct d:alldat
dbdir dblocal dbfpath
keys dbkeys header
allruns useserver ro
allruns-by-id buttondat searchpatts
numruns tot-runs num-tests
last-db-update updating
update-mutex
searchpatts
item-test-names
status-ignore-hash
state-ignore-hash
state-ignore-hash
status-ignore-hash
tot-runs
update-mutex
updaters
updating
useserver
)
(define *alldat* (make-d:alldat
header: #f
allruns: '()
allruns-by-id: (make-hash-table)
buttondat: (make-hash-table)
searchpatts: (make-hash-table)
numruns: 16
last-db-update: 0
please-update: #t
updating: #f
update-mutex: (make-mutex)
item-test-names: '()
num-tests: 15
start-run-offset: 0
start-test-offset: 0
status-ignore-hash: (make-hash-table)
state-ignore-hash: (make-hash-table)
hide-empty-runs: #f
hide-not-hide: #t
hide-not-hide-button: #f
hide-not-hide-tabs: #f
curr-tab-num: 0
updaters: (make-hash-table)
))
(d:alldat-useserver-set! *alldat* (cond
((args:get-arg "-use-local") #f)
((configf:lookup *configdat* "dashboard" "use-server")
(let ((ans (config:lookup *configdat* "dashboard" "use-server")))
(if (equal? ans "yes") #t #f)))
|
| ︙ | | |
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
-
-
+
+
+
+
|
(d:alldat-keys-set! *alldat* (if (d:alldat-useserver *alldat*)
(rmt:get-keys)
(db:get-keys (d:alldat-dblocal *alldat*))))
(d:alldat-dbkeys-set! *alldat* (append (d:alldat-keys *alldat*) (list "runname")))
(d:alldat-tot-runs-set! *alldat* (if (d:alldat-useserver *alldat*)
(rmt:get-num-runs "%")
(db:get-num-runs (d:alldat-dblocal *alldat*) "%")))
;; Update management
|
| ︙ | | |
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
-
-
-
-
-
-
-
-
|
(if t-sort
(cadr t-sort)
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
(define *hide-empty-runs* #f)
(define *hide-not-hide* #t) ;; toggle for hide/not hide
(define *hide-not-hide-button* #f)
(define *hide-not-hide-tabs* #f)
(define *current-tab-number* 0)
(define *updaters* (make-hash-table))
|
| ︙ | | |
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
|
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
|
-
+
-
+
|
(prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id *alldat*) run-id #f)))
(if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began
(prev-tests (vector-ref prev-dat 1))
(last-update (vector-ref prev-dat 3))
(tmptests (if (d:alldat-useserver *alldat*)
(rmt:get-tests-for-run run-id testnamepatt states statuses
#f #f
*hide-not-hide*
(d:alldat-hide-not-hide *alldat*)
sort-by
sort-order
'shortlist
last-update)
(db:get-tests-for-run (d:alldat-dblocal *alldat*) run-id testnamepatt states statuses
#f #f
*hide-not-hide*
(d:alldat-hide-not-hide *alldat*)
sort-by
sort-order
'shortlist
last-update)))
(tests (let ((newdat (filter
(lambda (x)
(not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
|
| ︙ | | |
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
|
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
|
-
+
|
;; (tests (bubble-up tmptests priority: bubble-type))
;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
;; Not sure this is needed?
(set! referenced-run-ids (cons run-id referenced-run-ids))
(if (> (length tests) maxtests)
(set! maxtests (length tests)))
(if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
(if (or (not (d:alldat-hide-empty-runs *alldat*)) ;; this reduces the data burden when set
(not (null? tests)))
(let ((dstruct (vector run tests key-vals (- (current-seconds) 10))))
(hash-table-set! (d:alldat-allruns-by-id *alldat*) run-id dstruct)
(set! result (cons dstruct result))))))
runs)
(d:alldat-header-set! *alldat* header)
|
| ︙ | | |
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
|
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
|
-
+
|
(set! *alltestnamelst* '())
;; create a concise list of test names
(for-each
(lambda (rundat)
(if (vector? rundat)
(let* ((testdat (vector-ref rundat 1))
(testnames (map test:test-get-fullname testdat)))
(if (not (and *hide-empty-runs*
(if (not (and (d:alldat-hide-empty-runs *alldat*)
(null? testnames)))
(for-each (lambda (testname)
(if (not (member testname *alltestnamelst*))
(begin
(set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
testnames)))))
runs)
|
| ︙ | | |
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
|
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
|
-
+
|
(define (set-bg-on-filter)
(let ((search-changed (not (null? (filter (lambda (key)
(not (equal? (hash-table-ref (d:alldat-searchpatts *alldat*) key) "%")))
(hash-table-keys (d:alldat-searchpatts *alldat*))))))
(state-changed (not (null? (hash-table-keys (d:alldat-state-ignore-hash *alldat*)))))
(status-changed (not (null? (hash-table-keys (d:alldat-status-ignore-hash *alldat*))))))
(iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR"
(iup:attribute-set! (d:alldat-hide-not-hide-tabs *alldat*) "BGCOLOR"
(if (or search-changed
state-changed
status-changed)
"190 180 190"
"190 190 190"
))))
|
| ︙ | | |
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
|
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
|
-
+
-
+
|
(tests-dat (let ((tdat (if run-id
(if (d:alldat-useserver *alldat*)
(rmt:get-tests-for-run run-id
(hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
(hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
(hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
#f #f
*hide-not-hide*
(d:alldat-hide-not-hide *alldat*)
#f #f
"id,testname,item_path,state,status"
last-update) ;; get 'em all
(db:get-tests-for-run db run-id
(hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
(hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
(hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
#f #f
*hide-not-hide*
(d:alldat-hide-not-hide *alldat*)
#f #f
"id,testname,item_path,state,status"
last-update))
'()))) ;; get 'em all
(sort tdat (lambda (a b)
(let* ((aval (vector-ref a 2))
(bval (vector-ref b 2))
|
| ︙ | | |
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
|
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
|
-
-
+
+
-
-
+
+
-
+
|
;; (set! *tests-sort-reverse* *tests-sort-reverse*0)
lb)
;; (iup:button "Sort -t" #:action (lambda (obj)
;; (next-sort-option)
;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
;; (mark-for-update)))
(iup:button "HideEmpty" #:action (lambda (obj)
(set! *hide-empty-runs* (not *hide-empty-runs*))
(iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE"))
(d:alldat-hide-empty-runs-set! *alldat* (not (d:alldat-hide-empty-runs *alldat*)))
(iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs *alldat*) "+HideE" "-HideE"))
(mark-for-update)))
(let ((hideit (iup:button "HideTests" #:action (lambda (obj)
(set! *hide-not-hide* (not *hide-not-hide*))
(iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
(d:alldat-hide-not-hide-set! *alldat* (not (d:alldat-hide-not-hide *alldat*)))
(iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide *alldat*) "HideTests" "NotHide"))
(mark-for-update)))))
(set! *hide-not-hide-button* hideit)
(d:alldat-hide-not-hide-button-set! *alldat* hideit) ;; never used, can eliminate ...
hideit))
(iup:hbox
(iup:button "Quit" #:action (lambda (obj)
;; (if (d:alldat-dblocal *alldat*) (db:close-all (d:alldat-dblocal *alldat*)))
(exit)))
(iup:button "Refresh" #:action (lambda (obj)
(mark-for-update)))
|
| ︙ | | |
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
|
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
|
-
+
-
+
|
;; the header
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst))))))
controls))
(tabs (iup:tabs
#:tabchangepos-cb (lambda (obj curr prev)
(d:alldat-please-update-set! *alldat* #t)
(set! *current-tab-number* curr))
(d:alldat-curr-tab-num-set! *alldat* curr))
(dashboard:summary db)
runs-view
(dashboard:one-run db)
(dashboard:run-controls)
)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
(iup:attribute-set! tabs "TABTITLE0" "Summary")
(iup:attribute-set! tabs "TABTITLE1" "Runs")
(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
(iup:attribute-set! tabs "TABTITLE3" "Run Control")
(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
(set! *hide-not-hide-tabs* tabs)
(d:alldat-hide-not-hide-tabs-set! *alldat* tabs)
tabs)))
(vector keycol lftcol header runsvec)))
(if (or (args:get-arg "-rows")
(get-environment-variable "DASHBOARDROWS" ))
(begin
(d:alldat-num-tests-set! *alldat* (string->number
|
| ︙ | | |
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
|
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
|
-
+
-
+
-
+
+
-
|
(define (dashboard:run-update x)
(let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time (d:alldat-dbfpath *alldat*)))
(monitor-modtime (if (file-exists? *monitor-db-path*)
(file-modification-time *monitor-db-path*)
-1))
(run-update-time (current-seconds))
(recalc (dashboard:recalc modtime (d:alldat-please-update *alldat*) (d:alldat-last-db-update *alldat*))))
(if (and (eq? *current-tab-number* 0)
(if (and (eq? (d:alldat-curr-tab-num *alldat*) 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)
(if dashboard:update-servers-table (dashboard:update-servers-table))))
(if recalc
(begin
(case *current-tab-number*
(case (d:alldat-curr-tab-num *alldat*)
((0)
(if dashboard:update-summary-tab (dashboard:update-summary-tab)))
((1) ;; The runs table is active
(update-rundat (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*)
(hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
;; (hash-table-ref/default (d:alldat-searchpatts *alldat*) "item-name" "%")
(let ((res '()))
(for-each (lambda (key)
(if (not (equal? key "runname"))
(let ((val (hash-table-ref/default (d:alldat-searchpatts *alldat*) key #f)))
(if val (set! res (cons (list key val) res))))))
(d:alldat-dbkeys *alldat*))
res))
(update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*)))
((2)
(dashboard:update-run-summary-tab))
(else
(let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f)))
(let ((updater (hash-table-ref/default (d:alldat-updaters *alldat*)
(d:alldat-curr-tab-num *alldat*) #f)))
(if updater (updater)))))
(d:alldat-please-update-set! *alldat* #f)
(d:alldat-last-db-update-set! *alldat* modtime)
;; (set! *last-update* run-update-time)
|
| ︙ | | |