| ︙ | | | ︙ | |
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
;; runs
((allruns '()) : list) ;; list of dboard:rundat records
((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
((done-runs '()) : list) ;; list of runs already drawn
((not-done-runs '()) : list) ;; list of runs not yet drawn
(header #f) ;; header for decoding the run records
(keys #f) ;; keys for this run (i.e. target components)
((numruns (string->number (or (args:get-arg "-cols") "8"))) : number) ;;
((tot-runs 0) : number)
((last-data-update 0) : number) ;; last time the data in allruns was updated
((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
(runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
|
|
|
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
;; runs
((allruns '()) : list) ;; list of dboard:rundat records
((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
((done-runs '()) : list) ;; list of runs already drawn
((not-done-runs '()) : list) ;; list of runs not yet drawn
(header #f) ;; header for decoding the run records
(keys #f) ;; keys for this run (i.e. target components)
((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;;
((tot-runs 0) : number)
((last-data-update 0) : number) ;; last time the data in allruns was updated
((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
(runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
|
| ︙ | | | ︙ | |
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
|
;; 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* ((num-to-get 20)
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
(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
|
|
>
>
|
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
|
;; 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* ((num-to-get (let ((n (configf:lookup *configdat* "dashboard" "num-to-get")))
(if n (string->number n)
30)))
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
(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
|
| ︙ | | | ︙ | |
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
|
(use-new (dboard:tabdat-hide-not-hide tabdat))
(tests-ht (if (dboard:tabdat-filters-changed tabdat)
(let ((ht (make-hash-table)))
(dboard:rundat-tests-set! run-dat ht)
ht)
(dboard:rundat-tests run-dat)))
(start-time (current-seconds)))
;; to limit the amount of data transferred each cycle use limit of num-to-get and offset
(dboard:rundat-run-data-offset-set!
run-dat
(if (< (length tmptests) num-to-get)
0
(let ((newval (+ num-to-get (dboard:rundat-run-data-offset run-dat))))
;; (print "Incremental get, offset=" (dboard:rundat-run-data-offset run-dat) " retrieved: " (length tmptests) " newval: " newval)
|
|
|
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
|
(use-new (dboard:tabdat-hide-not-hide tabdat))
(tests-ht (if (dboard:tabdat-filters-changed tabdat)
(let ((ht (make-hash-table)))
(dboard:rundat-tests-set! run-dat ht)
ht)
(dboard:rundat-tests run-dat)))
(start-time (current-seconds)))
;; (dashboard:set-db-update-time tabdat) ;; indicate that we did read the db at this time
;; to limit the amount of data transferred each cycle use limit of num-to-get and offset
(dboard:rundat-run-data-offset-set!
run-dat
(if (< (length tmptests) num-to-get)
0
(let ((newval (+ num-to-get (dboard:rundat-run-data-offset run-dat))))
;; (print "Incremental get, offset=" (dboard:rundat-run-data-offset run-dat) " retrieved: " (length tmptests) " newval: " newval)
|
| ︙ | | | ︙ | |
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
|
(define (update-search commondat tabdat x val)
(hash-table-set! (dboard:tabdat-searchpatts tabdat) x val)
(dboard:tabdat-filters-changed-set! tabdat #t)
(set-bg-on-filter commondat tabdat))
(define (mark-for-update tabdat)
(dboard:tabdat-filters-changed-set! tabdat #t)
(dboard:tabdat-last-db-update-set! tabdat 0))
;;======================================================================
;; R U N C O N T R O L
;;======================================================================
;; target populating logic
|
|
|
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
|
(define (update-search commondat tabdat x val)
(hash-table-set! (dboard:tabdat-searchpatts tabdat) x val)
(dboard:tabdat-filters-changed-set! tabdat #t)
(set-bg-on-filter commondat tabdat))
(define (mark-for-update tabdat)
;; (dboard:tabdat-filters-changed-set! tabdat #t)
(dboard:tabdat-last-db-update-set! tabdat 0))
;;======================================================================
;; R U N C O N T R O L
;;======================================================================
;; target populating logic
|
| ︙ | | | ︙ | |
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
|
(db-pth (conc db-dir "/" run-id ".db")))
(hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth)
db-pth)))
(tests-dat (if (or (not run-id)
(configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")
(not (hash-table-exists? (dboard:tabdat-last-test-dat tabdat) run-id))
(>= (file-modification-time db-path) last-update))
(dboard:get-tests-dat tabdat run-id last-update)
(hash-table-ref (dboard:tabdat-last-test-dat tabdat) run-id)))
(matrix-content
(case (dboard:tabdat-runs-summary-mode tabdat)
((one-run) (dcommon:minimize-test-data tests-dat))
((xor-two-runs) (dcommon:minimize-test-data tests-dat))
(else (dcommon:minimize-test-data tests-dat))))
(indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell))
|
|
|
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
|
(db-pth (conc db-dir "/" run-id ".db")))
(hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth)
db-pth)))
(tests-dat (if (or (not run-id)
(configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")
(not (hash-table-exists? (dboard:tabdat-last-test-dat tabdat) run-id))
(>= (file-modification-time db-path) last-update))
(dboard:get-tests-dat tabdat run-id 0) ;; last-update) ;; DO NOT USE last-update yet. Need to redesign this to use dboard:get-tests-for-run-duplicate
(hash-table-ref (dboard:tabdat-last-test-dat tabdat) run-id)))
(matrix-content
(case (dboard:tabdat-runs-summary-mode tabdat)
((one-run) (dcommon:minimize-test-data tests-dat))
((xor-two-runs) (dcommon:minimize-test-data tests-dat))
(else (dcommon:minimize-test-data tests-dat))))
(indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell))
|
| ︙ | | | ︙ | |
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
|
(oldmax (string->number (iup:attribute obj "MAX")))
(maxruns (dboard:tabdat-tot-runs tabdat)))
(dboard:tabdat-start-run-offset-set! tabdat val)
(mark-for-update tabdat)
(debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
(iup:attribute-set! obj "MAX" (* maxruns 10))))
#:expand "HORIZONTAL"
#:max (* 10 (length (dboard:tabdat-allruns tabdat)))
#:min 0
#:step 0.01)))
;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1))))
;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0))))
)))
(define (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt)
(iup:menu
(iup:menu-item
"Run"
(iup:menu
(iup:menu-item
(conc "Rerun " testpatt)
#:action
(lambda (obj)
;;(print "buttndat: " buttndat " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt)
(common:run-a-command
(conc "megatest -run -target " target
" -runname " runname
" -testpatt " testpatt
" -preclean -clean-cache")
)))
(iup:menu-item
|
|
|
|
|
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
|
(oldmax (string->number (iup:attribute obj "MAX")))
(maxruns (dboard:tabdat-tot-runs tabdat)))
(dboard:tabdat-start-run-offset-set! tabdat val)
(mark-for-update tabdat)
(debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
(iup:attribute-set! obj "MAX" (* maxruns 10))))
#:expand "HORIZONTAL"
#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
#:min 0
#:step 0.01)))
;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1))))
;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0))))
)))
(define (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt item-test-path)
(iup:menu
(iup:menu-item
"Run"
(iup:menu
(iup:menu-item
(conc "Rerun " testpatt)
#:action
(lambda (obj)
;; (print "buttndat: " buttndat " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
(common:run-a-command
(conc "megatest -run -target " target
" -runname " runname
" -testpatt " testpatt
" -preclean -clean-cache")
)))
(iup:menu-item
|
| ︙ | | | ︙ | |
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
|
(conc "megatest -remove-runs -target " target
" -runname " runname
" -testpatt % "))))))
(iup:menu-item
"Test"
(iup:menu
(iup:menu-item
(conc "Rerun " test-name)
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
" -runname " runname
" -testpatt " test-name
" -preclean -clean-cache"))))
(iup:menu-item
(conc "Kill " test-name)
#:action
(lambda (obj)
;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
(common:run-a-command
(conc "megatest -set-state-status KILLREQ,n/a -target " target
" -runname " runname
" -testpatt " test-name
" -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
(iup:menu-item
(conc "Clean " test-name)
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -remove-runs -target " target
" -runname " runname
" -testpatt " test-name))))
(iup:menu-item
"Start xterm"
#:action
(lambda (obj)
(dcommon:examine-xterm run-id test-id)))
;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&")))
;; (system cmd))))
|
|
|
|
|
|
|
|
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
|
(conc "megatest -remove-runs -target " target
" -runname " runname
" -testpatt % "))))))
(iup:menu-item
"Test"
(iup:menu
(iup:menu-item
(conc "Rerun " item-test-path)
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
" -runname " runname
" -testpatt " item-test-path
" -preclean -clean-cache"))))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
(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 "Clean "item-test-path)
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -remove-runs -target " target
" -runname " runname
" -testpatt " item-test-path))))
(iup:menu-item
"Start xterm"
#:action
(lambda (obj)
(dcommon:examine-xterm run-id test-id)))
;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&")))
;; (system cmd))))
|
| ︙ | | | ︙ | |
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
|
(test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
(testpatt (let ((tlast (rmt: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))
"%"))))
(iup:show (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
;; (print "got here")
))
(if (eq? pressed 0)
(let* ((toolpath (car (argv)))
|
|
>
>
>
>
|
|
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
|
(test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
(testpatt (let ((tlast (rmt: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 (rmt: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 buttndat run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
;; (print "got here")
))
(if (eq? pressed 0)
(let* ((toolpath (car (argv)))
|
| ︙ | | | ︙ | |
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
|
(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" "%")
10 ;; (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
;; old method
;; (let ((res '()))
|
|
|
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
|
(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
;; old method
;; (let ((res '()))
|
| ︙ | | | ︙ | |