| ︙ | | |
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
-
-
+
+
-
-
|
(let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat)))
(updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
tnum
'())))
(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
(for-each
(lambda (updater)
(debug:print 3 *default-log-port* "Running " updater)
(updater)
;; (debug:print 3 *default-log-port* "Running " updater)
(updater))
)
|
| ︙ | | |
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
|
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
|
-
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
|
#f #f ;; sort-by sort-order
#f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval
(if (dboard:tabdat-filters-changed tabdat)
0
last-update)
*dashboard-mode*)
'()))) ;; get 'em all
(debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
(sort tdat (lambda (a b)
(let* ((aval (vector-ref a 2))
(bval (vector-ref b 2))
(anum (string->number aval))
(bnum (string->number bval)))
(if (and anum bnum)
(< anum bnum)
(string<= aval bval)))))))
(define (dashboard:safe-cadr-assoc name lst)
(let ((res (assoc name lst)))
(if (and res (> (length res) 1))
(cadr res)
#f)))
(let ((run-ids (sort (filter number? (hash-table-keys runs-hash))
(lambda (a b)
(let* ((record-a (hash-table-ref runs-hash a))
(record-b (hash-table-ref runs-hash b))
(time-a (db:get-value-by-header record-a runs-header "event_time"))
(time-b (db:get-value-by-header record-b runs-header "event_time")))
(< time-a time-b))))))
(let* ((run-ids (sort (filter number? (hash-table-keys runs-hash))
(lambda (a b)
(let* ((record-a (hash-table-ref runs-hash a))
(record-b (hash-table-ref runs-hash b))
(time-a (db:get-value-by-header record-a runs-header "event_time"))
(time-b (db:get-value-by-header record-b runs-header "event_time")))
(< time-a time-b)))))
(changed #f)
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)))
(for-each (lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
(key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
(dboard:tabdat-keys tabdat)))
(run-name (db:get-value-by-header run-record runs-header "runname"))
(col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
(run-path (append key-vals (list run-name)))
|
| ︙ | | |
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
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
|
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
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
|
-
-
-
+
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
-
-
-
-
+
-
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
+
|
(changed #f)
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
(vector-ref runs-dat 1))
ht)))
(dboard:tabdat-filters-changed-set! tabdat #f)
(let loop ((pass-num 0)
(changed #f))
;; Update the runs tree
;; let loop ((pass-num 0)
;; (changed #f))
;; ;; Update the runs tree
(dboard:update-tree tabdat runs-hash runs-header tb)
(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")
(iup:attribute-set! run-matrix "NUMCOL" max-col )
(iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)))) ;; min of 20
;; Row labels
(for-each (lambda (ind)
(let* ((name (car ind))
(num (cadr ind))
(key (conc num ":0")))
(if (not (and (eq? pass-num 0) changed))
(set! changed (dcommon:modify-if-different run-matrix key name changed)))))
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)
(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 (let ((res (gutils:get-color-for-state-status state status)))
(if (and (list? res)
(> (length res) 1))
res
#f)))) ;; (list "n/a" "256 256 256"))))
(print "value: " value " row-name: " (cadr value) " row-color: " (car value))
(print "(assoc row-name row-indices): " (assoc row-name row-indices) " (assoc col-name col-indices): " (assoc col-name col-indices))
(if value
(let* ((row-name (cadr value))
(row-color (car value))
(row-num (dashboard:safe-cadr-assoc row-name row-indices)) ;; (cadr (assoc row-name row-indices)))
(col-num (dashboard:safe-cadr-assoc col-name col-indices))
(key (conc row-num ":" col-num)))
(if (and row-num col-num)
(begin
(hash-table-set! cell-lookup key test-id)
(set! changed (dcommon:modify-if-different run-matrix key row-name changed))
(set! changed (dcommon:modify-if-different run-matrix (conc "BGCOLOR" key) row-color changed)))
(print "ERROR: row-num=" row-num " col-num=" col-num))))
))
tests-mindat)
(if (and (eq? pass-num 0) changed)
(loop 1 #t)) ;; force second pass due to contents changing
;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
(for-each (lambda (ind)
(print "ind: " ind)
(let* ((name (car ind))
(num (cadr ind))
(key (conc "0:" num)))
(set! changed (dcommon:modify-if-different run-matrix key name changed))
(if changed (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-debug-port* "one-run-updater, changed: " changed " pass-num: " pass-num)
(print "one-run-updater, changed: " changed " pass-num: " pass-num)
(if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))
|
| ︙ | | |
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
|
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
|
-
|
(lambda (obj lin col status)
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
(cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&")))
(system cmd)))))
(one-run-updater (lambda ()
(print "Got here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!")
|
| ︙ | | |
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
|
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
|
+
+
|
recalc))
;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
(and (< lx1 px)(> lx2 px)))
(define (dashboard:summary-tab-updater commondat tab-num)
(if dashboard:update-summary-tab (dashboard:update-summary-tab)))
;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing
;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows)
;;
(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f))
(let ((lastrow (if num-rows (+ rownum num-rows) rownum)))
(let loop ((i 0)
(rowdat (hash-table-ref/default rowhash rownum '())))
|
| ︙ | | |
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
|
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
|
-
+
|
;; (print "target: " (dboard:tabdat-target tabdat))
(for-each (lambda (key)
(if (not (equal? key "runname"))
(let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
(if val (set! res (cons (list key val) res))))))
dbkeys)
res))))
(debug:print 0 *default-log-port* "fres: " fres)
;; (debug:print 0 *default-log-port* "fres: " fres)
fres)))
(let ((uidat (dboard:commondat-uidat commondat)))
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
"dashboard:runs-tab-updater"))
;; ((2)
|
| ︙ | | |
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
|
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
|
-
|
;; (dboard:commondat-add-updater
;; commondat
;; (lambda ()
;; (dashboard:summary-tab-updater commondat 0))
;; tab-num: 0)
;; runs tab
(dboard:commondat-curr-tab-num-set! commondat 0)
;; this next call is working and doing what it should
|
| ︙ | | |
| ︙ | | |
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
-
+
-
+
|
;; MOVE THIS INTO *data*
(define *cachedata* (make-hash-table))
(hash-table-set! *cachedata* "runid-to-col" (make-hash-table))
(hash-table-set! *cachedata* "testname-to-row" (make-hash-table))
;; modify a cell if the data is changed, return #t or-ed with previous if modified, #f elsewise
;;
(define (dcommon:modify-if-different mtrx cell-name new-val prev-changed)
(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed)
(let ((curr-val (iup:attribute mtrx cell-name)))
(if (not (equal? curr-val new-val))
(begin
(iup:attribute-set! mtrx cell-name new-val)
(iup:attribute-set! mtrx cell-name 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.
|
| ︙ | | |
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
-
+
|
(key-vals (map (lambda (key)(db:get-value-by-header run-record header key))
keys))
(run-name (db:get-value-by-header run-record header "runname"))
(col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
(run-path (append key-vals (list run-name))))
(hash-table-set! (dboard:tabdat-run-keys data) run-id run-path)
;; modify cell - but only if changed
(set! changed (dcommon:modify-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed))
(set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed))
(hash-table-set! runid-to-col run-id (list colnum run-record))
;; Here we update the tests treebox and tree keys
(tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name))
userdata: (conc "run-id: " run-id))
(set! colnum (+ colnum 1))))
run-ids)
|
| ︙ | | |
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
|
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
|
-
+
-
+
-
+
-
+
|
(tree:add-node (dboard:tabdat-tests-tree data) "Runs"
test-path
userdata: (conc "test-id: " test-id))
(let ((node-num (tree:find-node tb (cons "Runs" test-path)))
(color (car (gutils:get-color-for-state-status state status))))
(debug:print 0 *default-log-port* "node-num: " node-num ", color: " color)
(set! changed (dcommon:modify-if-different
(set! changed (dcommon:modifiy-if-different
tb
(conc "COLOR" node-num)
color changed))
;; (iup:attribute-set! tb (conc "COLOR" node-num) color)
)
(hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id)
(if (not rownum)
(let ((rownums (hash-table-values testname-to-row)))
(set! rownum (if (null? rownums)
1
(+ 1 (apply max rownums))))
(hash-table-set! testname-to-row fullname rownum)
;; create the label
(set! changed (dcommon:modify-if-different
(set! changed (dcommon:modifiy-if-different
(dboard:tabdat-runs-matrix data)
(conc rownum ":" 0)
dispname
changed))
;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; (conc rownum ":" 0) dispname)
))
;; set the cell text and color
;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status)
(set! changed (dcommon:modify-if-different
(set! changed (dcommon:modifiy-if-different
(dboard:tabdat-runs-matrix data)
(conc rownum ":" colnum)
(if (member state '("ARCHIVED" "COMPLETED"))
status
state)
changed))
;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; (conc rownum ":" colnum)
;; (if (member state '("ARCHIVED" "COMPLETED"))
;; status
;; state))
(set! changed (dcommon:modify-if-different
(set! changed (dcommon:modifiy-if-different
(dboard:tabdat-runs-matrix data)
(conc "BGCOLOR" rownum ":" colnum)
(car (gutils:get-color-for-state-status state status))
changed))
;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; (conc "BGCOLOR" rownum ":" colnum)
;; (car (gutils:get-color-for-state-status state status)))
|
| ︙ | | |