| ︙ | | |
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
|
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(define (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 (compare-tests test1 test2)
(define (dboard:compare-tests test1 test2)
(let* ((test-name1 (db:test-get-testname test1))
(item-path1 (db:test-get-item-path test1))
(eventtime1 (db:test-get-event_time test1))
(test-name2 (db:test-get-testname test2))
(item-path2 (db:test-get-item-path test2))
(eventtime2 (db:test-get-event_time test2))
(same-name (equal? test-name1 test-name2))
(test1-top (equal? item-path1 ""))
(test2-top (equal? item-path2 ""))
(test1-older (> eventtime1 eventtime2))
(same-time (equal? eventtime1 eventtime2)))
(if same-name
(if same-time
(string>? item-path1 item-path2)
test1-older)
(if same-time
(string>? test-name1 test-name2)
test1-older))))
;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
(define (dboard:get-tests-for-run-duplicate data run-id run testnamepatt key-vals)
(let* ((states (hash-table-keys (d:alldat-state-ignore-hash data)))
(statuses (hash-table-keys (d:alldat-status-ignore-hash data)))
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
'itempath))
(prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id data) 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 data)
(rmt:get-tests-for-run run-id testnamepatt states statuses
#f #f
(d:alldat-hide-not-hide data)
sort-by
sort-order
'shortlist
(if (d:alldat-filters-changed data)
0
last-update))
(db:get-tests-for-run (d:alldat-dblocal data) run-id testnamepatt states statuses
#f #f
(d:alldat-hide-not-hide data)
sort-by
sort-order
'shortlist
(if (d:alldat-filters-changed data)
0
last-update))))
(tests (let ((newdat (filter
(lambda (x)
(not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
(delete-duplicates (if (d:alldat-filters-changed data)
tmptests
(append tmptests prev-tests))
(lambda (a b)
(eq? (db:test-get-id a)(db:test-get-id b)))))))
(if (eq? *tests-sort-reverse* 3) ;; +event_time
(sort newdat dboard:compare-tests)
newdat))))
(debug:print 0 "(dboard:get-tests-for-run-duplicate: got " (length tests) " test records for run " run-id)
tests))
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat data runnamepatt numruns testnamepatt keypatts)
(let* ((referenced-run-ids '())
(allruns (if (d:alldat-useserver data)
(rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset data) keypatts)
(db:get-runs (d:alldat-dblocal data) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
(d:alldat-start-run-offset data) keypatts)))
(header (db:get-header allruns))
(runs (db:get-rows allruns))
(result '())
(maxtests 0)
(states (hash-table-keys (d:alldat-state-ignore-hash data)))
(statuses (hash-table-keys (d:alldat-status-ignore-hash data)))
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
'itempath)))
(prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id data) 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 data)
(rmt:get-tests-for-run run-id testnamepatt states statuses
#f #f
(d:alldat-hide-not-hide data)
sort-by
sort-order
'shortlist
last-update)
(db:get-tests-for-run (d:alldat-dblocal data) run-id testnamepatt states statuses
#f #f
(d:alldat-hide-not-hide data)
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
(delete-duplicates (append tmptests prev-tests)
(lambda (a b)
(eq? (db:test-get-id a)(db:test-get-id b)))))))
(if (eq? *tests-sort-reverse* 3) ;; +event_time
(sort newdat compare-tests)
newdat))))
|
| ︙ | | |
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
|
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
|
-
+
+
-
+
|
(status-changed (not (null? (hash-table-keys (d:alldat-status-ignore-hash *alldat*))))))
(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"
))))
))
(d:alldat-filters-changed-set! *alldat* #t)))
(define (update-search x val)
(hash-table-set! (d:alldat-searchpatts *alldat*) x val)
(d:alldat-set-filters-changed! *alldat* #t)
(d:alldat-filters-changed-set! *alldat* #t)
(set-bg-on-filter))
(define (mark-for-update)
(d:alldat-last-db-update-set! *alldat* 0))
;;======================================================================
;; R U N C O N T R O L
|
| ︙ | | |
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
|
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
|
+
|
(d:alldat-hide-not-hide data)
#f #f
"id,testname,item_path,state,status"
(if (d:alldat-filters-changed data)
0
last-update)))
'()))) ;; get 'em all
(debug:print 0 "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)
|
| ︙ | | |
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
|
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
|
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
|
tb
run-matrix)))
;;======================================================================
;; R U N S
;;======================================================================
(define (make-dashboard-buttons data nruns ntests keynames runs-sum-dat new-view-dat)
(let* ((db (d:alldat-dblocal data))
(nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(keycol (make-vector ntests))
(controls '())
(lftlst '())
(hdrlst '())
(bdylst '())
(result '())
(i 0))
;; controls (along bottom)
(set! controls
|
| ︙ | | |
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
|
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
|
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(iup:attribute-set! obj "MAX" (* maxruns 10))))
#:expand "HORIZONTAL"
#:max (* 10 (length (d:alldat-allruns data)))
#:min 0
#:step 0.01)))
;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (+ (d:alldat-num-tests data) 1))))
;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (if (> (d:alldat-num-tests data) 0)(- (d:alldat-num-tests data) 1) 0))))
)
)
))
(define (make-dashboard-buttons data nruns ntests keynames runs-sum-dat new-view-dat)
(let* ((db (d:alldat-dblocal data))
(nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(keycol (make-vector ntests))
(controls '())
(lftlst '())
(hdrlst '())
(bdylst '())
(result '())
(i 0))
;; controls (along bottom)
(set! controls (dboard:make-controls data))
;; create the left most column for the run key names and the test names
(set! lftlst (list (iup:hbox
(iup:label) ;; (iup:valuator)
(apply iup:vbox
(map (lambda (x)
(let ((res (iup:hbox #:expand "HORIZONTAL"
|
| ︙ | | |
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
|
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
|
-
+
+
+
-
+
+
|
(apply iup:hbox
(cons (apply iup:vbox lftlst)
(list
(iup:vbox
;; the header
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst))))))
controls))
;; controls
))
;; (data (d:data-init (make-d:data)))
(tabs (iup:tabs
#:tabchangepos-cb (lambda (obj curr prev)
(d:alldat-please-update-set! *alldat* #t)
(d:alldat-curr-tab-num-set! *alldat* curr))
(dashboard:summary *alldat*)
runs-view
(dashboard:one-run db data runs-sum-dat)
(dashboard:new-view db data new-view-dat)
(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" "New View")
(iup:attribute-set! tabs "TABTITLE4" "Run Control")
(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
(d:alldat-hide-not-hide-tabs-set! *alldat* tabs)
(iup:vbox
tabs)))
tabs
controls))))
(vector keycol lftcol header runsvec)))
(if (or (args:get-arg "-rows")
(get-environment-variable "DASHBOARDROWS" ))
(begin
(d:alldat-num-tests-set! *alldat* (string->number
(or (args:get-arg "-rows")
|
| ︙ | | |