| ︙ | | | ︙ | |
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
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 ==> dbstruct
;; (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
(ht (dboard:commondat-tabdats commondat))
(res (hash-table-ref/default ht tnum #f)))
(or res
(let ((new-tabdat (dboard:tabdat-make-data)))
(hash-table-set! ht tnum new-tabdat)
new-tabdat))))
;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
;;
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
(hash-table-set!
|
|
>
>
>
>
>
>
>
>
>
>
|
|
144
145
146
147
148
149
150
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
|
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)
(default-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 ==> dbstruct
;; (area-dbs #f) ;; use db:dashboard-open-db to add areas to the areas hash
)
;; general "db getter"
;;
(define (dboard:get-dbstruct commondat area-path-in) ;; area-path=#f gets local connection
(let ((areas (dboard:commondat-areas commondat))
(apath (or area-path-in (current-directory))))
(or (db:dashboard-open-dbstruct areas "local" apath)
(begin
(debug:print 0 *default-debug-port* "Failed to open db in directory " apath ", are you staring dashboard in a Megatest area? Exiting...")
(exit 1)))))
;; 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
(ht (dboard:commondat-tabdats commondat))
(res (hash-table-ref/default ht tnum #f)))
(or res
(let ((new-tabdat (dboard:tabdat-make-data commondat)))
(hash-table-set! ht tnum new-tabdat)
new-tabdat))))
;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
;;
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
(hash-table-set!
|
| ︙ | | | ︙ | |
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
|
(define (dboard:tabdat-test-patts-use vec)
(let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?
;; 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-make-data)
(let ((dat (make-dboard:tabdat)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(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
(defstruct dboard:graph-dat
((id #f) : string)
((color #f) : vector)
((flag #t) : boolean)
((cell #f) : number)
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
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
|
(define (dboard:tabdat-test-patts-use vec)
(let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?
;; 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-make-data commondat)
(let ((dat (make-dboard:tabdat)))
(dboard:setup-tabdat commondat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat commondat 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"))
(let ((dbstruct (dboard:get-dbstruct commondat #f)))
;; 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 (db:get-keys dbstruct))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
(dboard:tabdat-tot-runs-set! tabdat (db:get-num-runs dbstruct "%"))
))
;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
((id #f) : string)
((color #f) : vector)
((flag #t) : boolean)
((cell #f) : number)
|
| ︙ | | | ︙ | |
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
|
(define (dboard:runsdat-make-init)
(make-dboard:runsdat
runs-index: (make-hash-table)
tests-index: (make-hash-table)
matrix-dat: (make-sparse-array)))
;; used to keep the rundata from mrmt:get-tests-for-run
;; in sync.
;;
(defstruct dboard:rundat
run
tests-drawn ;; list of id's already drawn on screen
tests-notdrawn ;; list of id's NOT already drawn
rowsused ;; hash of lists covering what areas used - replace with quadtree
|
|
|
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
|
(define (dboard:runsdat-make-init)
(make-dboard:runsdat
runs-index: (make-hash-table)
tests-index: (make-hash-table)
matrix-dat: (make-sparse-array)))
;; used to keep the rundata from db:get-tests-for-run
;; in sync.
;;
(defstruct dboard:rundat
run
tests-drawn ;; list of id's already drawn on screen
tests-notdrawn ;; list of id's NOT already drawn
rowsused ;; hash of lists covering what areas used - replace with quadtree
|
| ︙ | | | ︙ | |
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
|
;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;; NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
(let* ((start-time (current-seconds))
|
|
>
|
|
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
|
;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;; NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals)
(let* ((dbstruct (dboard:get-dbstruct commondat #f))
(start-time (current-seconds))
(access-mode (dboard:tabdat-access-mode tabdat))
(num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")
"200")))
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
(do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
(do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
|
| ︙ | | | ︙ | |
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
|
;;(dboard:tabdat-filters-changed tabdat))
0
(dboard:rundat-last-update run-dat)))
(last-db-time (if do-not-use-db-file-timestamps
0
(dboard:rundat-last-db-time run-dat)))
(db-path (or (dboard:rundat-db-path run-dat)
(let* ((db-dir (common:get-db-tmp-area))
(db-pth (conc db-dir "/megatest.db")))
(dboard:rundat-db-path-set! run-dat db-pth)
db-pth)))
(db-mod-time (common:lazy-sqlite-db-modification-time db-path))
(db-modified (>= db-mod-time last-db-time))
(multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress
(tmptests (if (or do-not-use-db-file-timestamps
(dboard:tabdat-filters-changed tabdat)
db-modified)
(mrmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
(dboard:rundat-run-data-offset run-dat) ;; query offset
num-to-get
(dboard:tabdat-hide-not-hide tabdat) ;; no-in
sort-by ;; sort-by
sort-order ;; sort-order
#f ;; 'shortlist ;; qrytype
last-update ;; last-update
|
|
|
|
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
|
;;(dboard:tabdat-filters-changed tabdat))
0
(dboard:rundat-last-update run-dat)))
(last-db-time (if do-not-use-db-file-timestamps
0
(dboard:rundat-last-db-time run-dat)))
(db-path (or (dboard:rundat-db-path run-dat)
(let* ((db-dir (common:get-db-tmp-area dbstruct))
(db-pth (conc db-dir "/megatest.db")))
(dboard:rundat-db-path-set! run-dat db-pth)
db-pth)))
(db-mod-time (common:lazy-sqlite-db-modification-time db-path))
(db-modified (>= db-mod-time last-db-time))
(multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress
(tmptests (if (or do-not-use-db-file-timestamps
(dboard:tabdat-filters-changed tabdat)
db-modified)
(db:get-tests-for-run dbstruct run-id testnamepatt states statuses ;; run-id testpatt states statuses
(dboard:rundat-run-data-offset run-dat) ;; query offset
num-to-get
(dboard:tabdat-hide-not-hide tabdat) ;; no-in
sort-by ;; sort-by
sort-order ;; sort-order
#f ;; 'shortlist ;; qrytype
last-update ;; last-update
|
| ︙ | | | ︙ | |
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
|
;; newdat)))
;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(keys (mrmt:get-keys))
(allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
(allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname")
(header (db:get-header allruns))
(runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
(runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
(start-time (current-seconds))
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run header "id") run))
|
|
>
|
|
|
<
|
|
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
|
;; newdat)))
;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((dbstruct (dboard:get-dbstruct commondat #f)) ;; get access to local area
(access-mode (dboard:tabdat-access-mode tabdat))
(keys (db:get-keys dbstruct))
(last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
(allruns (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
(allruns-tree (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname")
(header (db:get-header allruns))
(runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
(runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
(start-time (current-seconds))
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run header "id") run))
|
| ︙ | | | ︙ | |
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
|
(let loop ((run (car runs))
(tal (cdr runs))
(res '())
(maxtests 0))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
(last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
(key-vals (mrmt:get-key-vals run-id))
(tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
;; dboard:get-tests-for-run-duplicate - returns a hash table
;; (dboard:get-tests-dat tabdat run-id last-update))
(all-test-ids (hash-table-keys tests-ht))
(num-tests (length all-test-ids)))
;; (print "run-struct: " run-struct)
;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
|
|
|
|
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
|
(let loop ((run (car runs))
(tal (cdr runs))
(res '())
(maxtests 0))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
(last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
(key-vals (db:get-key-vals dbstruct run-id))
(tests-ht (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals))
;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
;; dboard:get-tests-for-run-duplicate - returns a hash table
;; (dboard:get-tests-dat tabdat run-id last-update))
(all-test-ids (hash-table-keys tests-ht))
(num-tests (length all-test-ids)))
;; (print "run-struct: " run-struct)
;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
|
| ︙ | | | ︙ | |
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
|
(dboard:update-tree tabdat runs-hash header tb)))
;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode mrmt:get-keys db:get-keys)))
(allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
(allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
(header (db:get-header allruns))
(runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
(runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
(start-time (current-seconds))
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run header "id") run))
|
|
>
|
|
|
|
|
|
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
|
(dboard:update-tree tabdat runs-hash header tb)))
;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((dbstruct (dboard:get-dbstruct commondat #f))
(access-mode (dboard:tabdat-access-mode tabdat))
(keys (dboard:tabdat-keys tabdat))
(last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
(allruns (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
;;(allruns-tree (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
(allruns-tree (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
(header (db:get-header allruns))
(runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
(runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
(start-time (current-seconds))
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run header "id") run))
|
| ︙ | | | ︙ | |
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
|
(let loop ((run (car runs))
(tal (cdr runs))
(res '())
(maxtests 0))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
(key-vals (mrmt:get-key-vals run-id))
(tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
;; dboard:get-tests-for-run-duplicate - returns a hash table
;; (dboard:get-tests-dat tabdat run-id last-update))
(all-test-ids (hash-table-keys tests-ht))
(num-tests (length all-test-ids)))
;; (print "run-struct: " run-struct)
;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
|
|
|
|
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
|
(let loop ((run (car runs))
(tal (cdr runs))
(res '())
(maxtests 0))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
(key-vals (db:get-key-vals dbstruct run-id))
(tests-ht (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals))
;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
;; dboard:get-tests-for-run-duplicate - returns a hash table
;; (dboard:get-tests-dat tabdat run-id last-update))
(all-test-ids (hash-table-keys tests-ht))
(num-tests (length all-test-ids)))
;; (print "run-struct: " run-struct)
;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
|
| ︙ | | | ︙ | |
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
|
(if val
val
(if (not (null? values))
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
(db-target-dat (mrmt:get-targets))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
(list->vector
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header)))))
|
|
>
|
|
|
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
|
(if val
val
(if (not (null? values))
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector commondat tabdat #!key (action-proc #f))
(let* ((dbstruct (dboard:get-dbstruct commondat #f))
(runconf-targs (common:get-runconfig-targets))
(key-lbs (dboard:tabdat-key-listboxes tabdat))
(db-target-dat (db:get-targets dbstruct))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
(list->vector
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header)))))
|
| ︙ | | | ︙ | |
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
|
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dboard:target-updater tabdat) ;; key-listboxes)
(let ((targ (map (lambda (x)
(iup:attribute x "VALUE"))
(car (dashboard:update-target-selector tabdat))))
(curr-runname (dboard:tabdat-run-name tabdat)))
(dboard:tabdat-target-set! tabdat targ)
;; (if (dboard:tabdat-updater-for-runs tabdat)
;; ((dboard:tabdat-updater-for-runs tabdat)))
(if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
(equal? (dboard:tabdat-run-name tabdat) ""))
(dboard:tabdat-run-name-set! tabdat curr-runname))
(dashboard:update-run-command tabdat)))
;; used by run-controls
;;
(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
(let* ((tb (dboard:tabdat-runs-tree tabdat))
(db-target-dat (mrmt:get-targets))
(runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header))))
|
|
|
|
>
|
|
|
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
|
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dboard:target-updater commondat tabdat) ;; key-listboxes)
(let ((targ (map (lambda (x)
(iup:attribute x "VALUE"))
(car (dashboard:update-target-selector commondat tabdat))))
(curr-runname (dboard:tabdat-run-name tabdat)))
(dboard:tabdat-target-set! tabdat targ)
;; (if (dboard:tabdat-updater-for-runs tabdat)
;; ((dboard:tabdat-updater-for-runs tabdat)))
(if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
(equal? (dboard:tabdat-run-name tabdat) ""))
(dboard:tabdat-run-name-set! tabdat curr-runname))
(dashboard:update-run-command tabdat)))
;; used by run-controls
;;
(define (dashboard:update-tree-selector commondat tabdat #!key (action-proc #f))
(let* ((dbstruct (dboard:get-dbstruct commondat #f))
(tb (dboard:tabdat-runs-tree tabdat))
(runconf-targs (common:get-runconfig-targets))
(db-target-dat (db:get-targets dbstruct))
(runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header))))
|
| ︙ | | | ︙ | |
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
|
(test-names (hash-table-keys all-tests-registry))
(sorted-testnames #f)
(action "-run")
(cmdln "")
(runlogs (make-hash-table))
;;; (key-listboxes #f)
(update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
(dboard:target-updater (dboard:tabdat-key-listboxes tabdat))))
(tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
(test-patterns-textbox #f))
(hash-table-set! tests-draw-state 'first-time #t)
;; (hash-table-set! tests-draw-state 'scalef 1)
(tests:get-full-data test-names test-records '() all-tests-registry)
(set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
|
|
|
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
|
(test-names (hash-table-keys all-tests-registry))
(sorted-testnames #f)
(action "-run")
(cmdln "")
(runlogs (make-hash-table))
;;; (key-listboxes #f)
(update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
(dboard:target-updater commondat (dboard:tabdat-key-listboxes tabdat))))
(tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
(test-patterns-textbox #f))
(hash-table-set! tests-draw-state 'first-time #t)
;; (hash-table-set! tests-draw-state 'scalef 1)
(tests:get-full-data test-names test-records '() all-tests-registry)
(set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
|
| ︙ | | | ︙ | |
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
|
;; key-listboxes))
(dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))))
(tb (dboard:tabdat-runs-tree tabdat)))
(dboard:commondat-add-updater
commondat
(lambda ()
(if (dashboard:database-changed? commondat tabdat context-key: 'run-control)
(dashboard:update-tree-selector tabdat)))
tab-num: tab-num)
result)))
;;(iup:frame
;; #:title "Logs" ;; To be replaced with tabs
;; (let ((logs-tb (iup:textbox #:expand "YES"
;; #:multiline "YES")))
|
|
|
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
|
;; key-listboxes))
(dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))))
(tb (dboard:tabdat-runs-tree tabdat)))
(dboard:commondat-add-updater
commondat
(lambda ()
(if (dashboard:database-changed? commondat tabdat context-key: 'run-control)
(dashboard:update-tree-selector commondat tabdat)))
tab-num: tab-num)
result)))
;;(iup:frame
;; #:title "Logs" ;; To be replaced with tabs
;; (let ((logs-tb (iup:textbox #:expand "YES"
;; #:multiline "YES")))
|
| ︙ | | | ︙ | |
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
|
(dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
(dboard:tabdat-running-layout-set! tabdat #f))
"run-times-tab-layout-updater")))
))))))
"dashboard:run-times-tab-updater")))
(key-listboxes #f) ;;
(update-keyvals (lambda ()
(dboard:target-updater tabdat))))
(dboard:tabdat-drawing-set! tabdat drawing)
(dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
#:value 150
(iup:vbox
|
|
|
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
|
(dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
(dboard:tabdat-running-layout-set! tabdat #f))
"run-times-tab-layout-updater")))
))))))
"dashboard:run-times-tab-updater")))
(key-listboxes #f) ;;
(update-keyvals (lambda ()
(dboard:target-updater commondat tabdat))))
(dboard:tabdat-drawing-set! tabdat drawing)
(dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
#:value 150
(iup:vbox
|
| ︙ | | | ︙ | |
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
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
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
|
;; display and manage a single run at a time
(define (tree-path->run-id tabdat path)
(if (not (null? path))
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
;; (define (dboard:get-tests-dat tabdat run-id last-update)
;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
;; (tdat (if run-id (db:dispatch-query access-mode mrmt:get-tests-for-run db:get-tests-for-run
;; run-id
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '()
;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
;; #f #f ;; offset limit
;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in
;; #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)
;; (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)))))))
;; (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(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))
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
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
1677
1678
1679
1680
|
;; display and manage a single run at a time
(define (tree-path->run-id tabdat path)
(if (not (null? path))
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
(define (dashboard:safe-cadr-assoc name lst)
(let ((res (assoc name lst)))
(if (and res (> (length res) 1))
(cadr res)
#f)))
(define (dboard:update-tree tabdat runs-hash runs-header tb)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(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)
(last-runs-update (dboard:tabdat-last-runs-update tabdat)))
;; (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(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))
|
| ︙ | | | ︙ | |
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
1807
1808
|
(cond
((< 0 (string-compare3 a-test-name b-test-name)) #t)
((> 0 (string-compare3 a-test-name b-test-name)) #f)
((< 0 (string-compare3 a-item-path b-item-path)) #t)
(else #f)))))))
(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
(let* ((run (hash-table-ref/default runs-hash run-id #f))
(key-vals (mrmt:get-key-vals run-id))
(testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
(tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
(tests-dat (dashboard:tests-ht->tests-dat tests-ht))
(tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
(hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
(when (not run)
(debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
(debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
)
tests-mindat))
(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))
(let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
(dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
(dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
hide-clean: hide-clean)
#f)))
(define (dashboard:get-runs-hash tabdat)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(last-runs-update 0);;(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 (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)))
runs-hash))
(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
(dashboard:do-update-rundat tabdat) ;; )
(dboard:runs-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: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))
)
((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash))
((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash))
((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))
(else (dashboard: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))
;; Update the runs tree
;; (dboard:update-tree tabdat runs-hash runs-header tb)
|
|
>
|
|
|
>
|
|
|
|
>
|
|
|
>
|
|
|
|
|
|
<
<
<
<
<
<
|
|
|
|
|
<
|
1707
1708
1709
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
|
(cond
((< 0 (string-compare3 a-test-name b-test-name)) #t)
((> 0 (string-compare3 a-test-name b-test-name)) #f)
((< 0 (string-compare3 a-item-path b-item-path)) #t)
(else #f)))))))
(define (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash)
(let* ((run (hash-table-ref/default runs-hash run-id #f))
(dbstruct (dboard:get-dbstruct commondat #f))
(key-vals (db:get-key-vals dbstruct run-id))
(testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
(tests-ht (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals))
(tests-dat (dashboard:tests-ht->tests-dat tests-ht))
(tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
(hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
(when (not run)
(debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
(debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
)
tests-mindat))
(define (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f))
(let* (;; (dbstruct (dboard:get-dbstruct commondat #f))
(src-run-id (dboard:tabdat-prev-run-id tabdat))
(dest-run-id (dboard:tabdat-curr-run-id tabdat)))
(if (and src-run-id dest-run-id)
(dcommon:xor-tests-mindat
(dashboard:run-id->tests-mindat commondat src-run-id tabdat runs-hash)
(dashboard:run-id->tests-mindat commondat dest-run-id tabdat runs-hash)
hide-clean: hide-clean)
#f)))
(define (dashboard:get-runs-hash commondat tabdat)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(dbstruct (dboard:get-dbstruct commondat #f))
(last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
(runs-dat (db:get-runs-by-patt dbstruct (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 (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)))
runs-hash))
(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
(dashboard:do-update-rundat commondat tabdat) ;; )
(dboard:runs-summary-control-panel-updater commondat tabdat)
(let* ((dbstruct (dboard:get-dbstruct commondat #f))
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (db:get-runs-by-patt dbstruct (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:get-runs-hash commondat tabdat)))
(if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree)
(dboard:update-tree tabdat runs-hash runs-header tb))
(if run-id
(let* ((matrix-content
(case (dboard:tabdat-runs-summary-mode tabdat)
((one-run) (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash))
((xor-two-runs) (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash))
((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash hide-clean: #t))
(else (dashboard:run-id->tests-mindat commondat 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))
;; Update the runs tree
;; (dboard:update-tree tabdat runs-hash runs-header tb)
|
| ︙ | | | ︙ | |
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
|
;;======================================================================
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
(let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
|
>
>
>
|
|
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
|
;;======================================================================
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
(let* ((dbstruct (dboard:get-dbstruct commondat #f))
(configdat (dbr:dbstruct-configdat dbstruct))
(rawconfig configdat)
;; (rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(changed #f))
(iup:vbox
(iup:split
#:value 300
(iup:frame
#:title "General Info"
(iup:vbox
|
| ︙ | | | ︙ | |
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
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
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
|
(nonsel-color "170 170 170")
(current-mode (dboard:tabdat-runs-summary-mode tabdat)))
(if (eq? this-mode current-mode)
(iup:attribute-set! this-button "BGCOLOR" sel-color)
(iup:attribute-set! this-button "BGCOLOR" nonsel-color))
(loop (cdr buttons-left) (cdr modes-left))))))
(define (dboard:runs-summary-xor-labels-updater tabdat)
(let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
(dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
(mode (dboard:tabdat-runs-summary-mode tabdat)))
(when (and source-runname-label dest-runname-label)
(case mode
((xor-two-runs xor-two-runs-hide-clean)
(let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat))
(prev-run-id (dboard:tabdat-prev-run-id tabdat))
(curr-runname (if curr-run-id
(mrmt:get-run-name-from-id curr-run-id)
"None"))
(prev-runname (if prev-run-id
(mrmt:get-run-name-from-id prev-run-id)
"None")))
(iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" "))
(iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" "))))
(else
(iup:attribute-set! source-runname-label "TITLE" "")
(iup:attribute-set! dest-runname-label "TITLE" ""))))))
(define (dboard:runs-summary-control-panel-updater tabdat)
(dboard:runs-summary-xor-labels-updater tabdat)
(dboard:runs-summary-buttons-updater tabdat))
;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:runs-summary-control-panel tabdat)
(let* ((summary-buttons ;; build buttons
(map
(lambda (mode-item)
(let* ((this-mode (car mode-item))
(this-mode-label (cdr mode-item)))
(iup:button this-mode-label
#:action
(lambda (obj)
(debug:catch-and-dump
(lambda ()
(dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
(dboard:runs-summary-control-panel-updater tabdat))
"runs summary control panel updater")))))
(dboard:tabdat-runs-summary-modes tabdat)))
(summary-buttons-hbox (apply iup:hbox summary-buttons))
(xor-runname-labels-hbox
(iup:hbox
(let ((temp-label
(iup:label "" #:size "125x15" #:fontsize "10" )))
(dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
temp-label
)
(let ((temp-label
(iup:label "" #:size "125x15" #:fontsize "10")))
(dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
temp-label))))
(dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)
;; maybe wrap in a frame
(let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
(dboard:runs-summary-control-panel-updater tabdat)
res
)))
;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
;; This is the Run Summary tab
;;
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
(let* ((update-mutex (dboard:commondat-update-mutex commondat))
|
|
|
|
>
|
|
|
|
|
|
|
>
|
|
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
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
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
|
(nonsel-color "170 170 170")
(current-mode (dboard:tabdat-runs-summary-mode tabdat)))
(if (eq? this-mode current-mode)
(iup:attribute-set! this-button "BGCOLOR" sel-color)
(iup:attribute-set! this-button "BGCOLOR" nonsel-color))
(loop (cdr buttons-left) (cdr modes-left))))))
(define (dboard:runs-summary-xor-labels-updater commondat tabdat)
(let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
(dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
(mode (dboard:tabdat-runs-summary-mode tabdat))
(dbstruct (dboard:get-dbstruct commondat #f)))
(when (and source-runname-label dest-runname-label)
(case mode
((xor-two-runs xor-two-runs-hide-clean)
(let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat))
(prev-run-id (dboard:tabdat-prev-run-id tabdat))
(curr-runname (if curr-run-id
(db:get-run-name-from-id dbstruct curr-run-id)
"None"))
(prev-runname (if prev-run-id
(db:get-run-name-from-id dbstruct prev-run-id)
"None")))
(iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" "))
(iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" "))))
(else
(iup:attribute-set! source-runname-label "TITLE" "")
(iup:attribute-set! dest-runname-label "TITLE" ""))))))
(define (dboard:runs-summary-control-panel-updater commondat tabdat)
(dboard:runs-summary-xor-labels-updater commondat tabdat)
(dboard:runs-summary-buttons-updater tabdat))
;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:runs-summary-control-panel commondat tabdat)
(let* ((summary-buttons ;; build buttons
(map
(lambda (mode-item)
(let* ((this-mode (car mode-item))
(this-mode-label (cdr mode-item)))
(iup:button this-mode-label
#:action
(lambda (obj)
(debug:catch-and-dump
(lambda ()
(dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
(dboard:runs-summary-control-panel-updater commondattabdat))
"runs summary control panel updater")))))
(dboard:tabdat-runs-summary-modes tabdat)))
(summary-buttons-hbox (apply iup:hbox summary-buttons))
(xor-runname-labels-hbox
(iup:hbox
(let ((temp-label
(iup:label "" #:size "125x15" #:fontsize "10" )))
(dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
temp-label
)
(let ((temp-label
(iup:label "" #:size "125x15" #:fontsize "10")))
(dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
temp-label))))
(dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)
;; maybe wrap in a frame
(let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
(dboard:runs-summary-control-panel-updater commondat tabdat)
res
)))
;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
;; This is the Run Summary tab
;;
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
(let* ((dbstruct (dboard:get-dbstruct commondat #f))
(update-mutex (dboard:commondat-update-mutex commondat))
(tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "YES"
#:selection-cb
(lambda (obj id state)
|
| ︙ | | | ︙ | |
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
|
(debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(run-info (mrmt:get-run-info run-id))
(target (mrmt:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-info (mrmt:get-test-info-by-id run-id test-id))
(test-name (db:test-get-testname test-info))
(testpatt (let ((tlast (mrmt:tasks-get-last target runname)))
(if tlast
(let ((tpatt (tasks:task-get-testpatt tlast)))
(if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
"%"
tpatt))
"%")))
(item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id)))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path)))
(status-chars (char-set->list (string->char-set status)))
(testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
(debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
(cond
|
|
|
|
|
|
|
|
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
|
(debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(run-info (db:get-run-info dbstruct run-id))
(target (db:get-target dbstruct run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-info (db:get-test-info-by-id dbstruct run-id test-id))
(test-name (db:test-get-testname test-info))
(testpatt (let ((tlast (db:tasks-get-last dbstruct target runname)))
(if tlast
(let ((tpatt (tasks:task-get-testpatt tlast))) ;; tasks:task-get-testpatt is an accessor defined in task_records.scm
(if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
"%"
tpatt))
"%")))
(item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id)))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path)))
(status-chars (char-set->list (string->char-set status)))
(testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
(debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
(cond
|
| ︙ | | | ︙ | |
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
|
(debug:catch-and-dump
(lambda () ;; check that run-matrix is initialized before calling the updater
(if run-matrix
(dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
"dashboard:runs-summary-updater")
)
(mutex-unlock! update-mutex)))
(runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
)
(dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:vbox
(iup:split
#:value 200
tb
|
|
|
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
|
(debug:catch-and-dump
(lambda () ;; check that run-matrix is initialized before calling the updater
(if run-matrix
(dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
"dashboard:runs-summary-updater")
)
(mutex-unlock! update-mutex)))
(runs-summary-control-panel (dashboard:runs-summary-control-panel commondat tabdat))
)
(dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:vbox
(iup:split
#:value 200
tb
|
| ︙ | | | ︙ | |
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
|
(lambda (obj)
(dcommon:examine-xterm run-id test-id)))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
|
<
|
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
|
(lambda (obj)
(dcommon:examine-xterm run-id test-id)))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -set-state-status KILLREQ,n/a -target " target
" -runname " runname
" -testpatt " item-test-path
" -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
|
| ︙ | | | ︙ | |
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
|
" -runname " runname
" -testpatt " item-test-path
" -preclean -clean-cache"))))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
|
<
|
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
|
" -runname " runname
" -testpatt " item-test-path
" -preclean -clean-cache"))))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -set-state-status KILLREQ,n/a -target " target
" -runname " runname
" -testpatt " item-test-path
" -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
(iup:menu-item
(conc "Delete data : " item-test-path)
|
| ︙ | | | ︙ | |
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
|
(conc "xterm -e " editor)
editor)
" " tconfig " &")))
(system cmd))))
))))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
(let* ((stats-dat (dboard:tabdat-make-data))
(runs-dat (dboard:tabdat-make-data))
(onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure
(runcontrols-dat (dboard:tabdat-make-data))
(runtimes-dat (dboard:tabdat-make-data))
(areas-dat (dboard:tabdat-make-data))
|
>
|
|
|
|
|
|
|
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
|
(conc "xterm -e " editor)
editor)
" " tconfig " &")))
(system cmd))))
))))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
(let* ((dbstruct (dboard:get-dbstruct commondat #f))
(stats-dat (dboard:tabdat-make-data commondat))
(runs-dat (dboard:tabdat-make-data commondat))
(onerun-dat (dboard:tabdat-make-data commondat)) ;; name for run-summary structure
(runcontrols-dat (dboard:tabdat-make-data commondat))
(runtimes-dat (dboard:tabdat-make-data commondat))
(areas-dat (dboard:tabdat-make-data commondat))
(nruns (dboard:tabdat-numruns runs-dat))
(ntests (dboard:tabdat-num-tests runs-dat))
(keynames (dboard:tabdat-dbkeys runs-dat))
(nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
|
| ︙ | | | ︙ | |
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
|
(let loop ((testnum 0)
(res '()))
(cond
((>= testnum ntests)
;; now lftlst will be an hbox with the test keys and the test name labels
(set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL"
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (string->number (iup:attribute obj "VALUE")))
(oldmax (string->number (iup:attribute obj "MAX")))
(newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
(debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax)
(if (< val 10)
(iup:attribute-set! obj "MAX" newmax))
|
|
|
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
|
(let loop ((testnum 0)
(res '()))
(cond
((>= testnum ntests)
;; now lftlst will be an hbox with the test keys and the test name labels
(set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL"
(iup:valuator #:valuechanged_cb (lambda (obj)
668 (let ((val (string->number (iup:attribute obj "VALUE")))
(oldmax (string->number (iup:attribute obj "MAX")))
(newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
(debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax)
(if (< val 10)
(iup:attribute-set! obj "MAX" newmax))
|
| ︙ | | | ︙ | |
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
|
;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
(if (substring-index "3" btn)
(if (eq? pressed 1)
(let* ((toolpath (car (argv)))
(buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
(run-id (db:test-get-run_id (vector-ref buttndat 3)))
(run-info (mrmt:get-run-info run-id))
(target (mrmt:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-info (mrmt:get-test-info-by-id run-id test-id))
(test-name (db:test-get-testname test-info))
(testpatt (let ((tlast (mrmt:tasks-get-last target runname)))
(if tlast
(let ((tpatt (tasks:task-get-testpatt tlast)))
(if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
"%"
tpatt))
"%")))
(item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id)))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path))))
(iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
|
|
|
|
|
|
|
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
|
;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
(if (substring-index "3" btn)
(if (eq? pressed 1)
(let* ((toolpath (car (argv)))
(buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
(run-id (db:test-get-run_id (vector-ref buttndat 3)))
(run-info (db:get-run-info dbstruct run-id))
(target (db:get-target dbstruct run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-info (db:get-test-info-by-id dbstruct run-id test-id))
(test-name (db:test-get-testname test-info))
(testpatt (let ((tlast (db:tasks-get-last dbstruct target runname)))
(if tlast
(let ((tpatt (tasks:task-get-testpatt tlast)))
(if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
"%"
tpatt))
"%")))
(item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id)))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path))))
(iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
|
| ︙ | | | ︙ | |
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
|
(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
(db:test-get-event_time (hash-table-ref testsdat (car b))))))))))
;; run times tab data updater
;;
(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(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-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))
(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)))))
(tb (dboard:tabdat-runs-tree tabdat))
(num-runs (length (hash-table-keys runs-hash)))
(update-start-time (current-seconds))
(inc-mode #f))
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
;; fill in the tree
(if (and tb
(not inc-mode))
(for-each
(lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
|
(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
(db:test-get-event_time (hash-table-ref testsdat (car b))))))))))
;; run times tab data updater
;;
(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(dbstruct (dboard:get-dbstruct commondat #f))
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (db:get-runs-by-patt dbstruct (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-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))
(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)))))
(tb (dboard:tabdat-runs-tree tabdat))
(num-runs (length (hash-table-keys runs-hash)))
(update-start-time (current-seconds))
(inc-mode #f))
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
;; fill in the tree
(if (and tb
(not inc-mode))
(for-each
(lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
|
| ︙ | | | ︙ | |
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
|
(vg:drawing-libs-set! dwg (make-hash-table))
(vg:drawing-insts-set! dwg (make-hash-table))
(vg:drawing-cache-set! dwg '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
;; (dboard:tabdat-allruns-set! tabdat '())
(dboard:tabdat-max-row-set! tabdat 0)
(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
(update-rundat tabdat
runpatt
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(dboard:tabdat-numruns tabdat)
testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
targpatt
|
|
>
|
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
|
(vg:drawing-libs-set! dwg (make-hash-table))
(vg:drawing-insts-set! dwg (make-hash-table))
(vg:drawing-cache-set! dwg '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
;; (dboard:tabdat-allruns-set! tabdat '())
(dboard:tabdat-max-row-set! tabdat 0)
(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
(update-rundat commondat
tabdat
runpatt
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(dboard:tabdat-numruns tabdat)
testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
targpatt
|
| ︙ | | | ︙ | |
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
|
;;
;; removing the tabdat-values proc
;;
;; (define (tabdat-values tabdat)
;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:do-update-rundat tabdat)
(dboard:update-rundat
tabdat
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(dboard:tabdat-numruns tabdat)
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; generate key patterns from the target stored in tabdat
(let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
(let ((fres (if (dboard:tabdat-target tabdat)
|
|
>
|
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
|
;;
;; removing the tabdat-values proc
;;
;; (define (tabdat-values tabdat)
;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:do-update-rundat commondat tabdat)
(dboard:update-rundat
commondat
tabdat
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(dboard:tabdat-numruns tabdat)
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; generate key patterns from the target stored in tabdat
(let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
(let ((fres (if (dboard:tabdat-target tabdat)
|
| ︙ | | | ︙ | |
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
|
(lambda ()
(let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
(dbkeys (dboard:tabdat-dbkeys tabdat)))
;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
;;(tabdat-values tabdat) ;;RA added
;; (pp (dboard:tabdat->alist tabdat))
;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)
(dashboard:do-update-rundat tabdat)
;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater")
;;(inspect tabdat)
(let ((uidat (dboard:commondat-uidat commondat)))
;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
|
|
|
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
|
(lambda ()
(let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
(dbkeys (dboard:tabdat-dbkeys tabdat)))
;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
;;(tabdat-values tabdat) ;;RA added
;; (pp (dboard:tabdat->alist tabdat))
;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)
(dashboard:do-update-rundat commondat tabdat)
;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater")
;;(inspect tabdat)
(let ((uidat (dboard:commondat-uidat commondat)))
;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
|
| ︙ | | | ︙ | |