| ︙ | | | ︙ | |
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
(exit)))
(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
(defstruct dboard:commondat
curr-tab-num
please-update
tabdats
update-mutex
updaters
updating
hide-not-hide-tabs
)
(define (dboard:commondat-make)
(make-dboard:commondat
curr-tab-num: 0
tabdats: (make-hash-table)
|
>
>
>
|
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
(exit)))
(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
;; data common to all tabs goes here
;;
(defstruct dboard:commondat
curr-tab-num
please-update
tabdats
update-mutex
updaters
updating
uidat ;; needs to move to tabdat at some time
hide-not-hide-tabs
)
(define (dboard:commondat-make)
(make-dboard:commondat
curr-tab-num: 0
tabdats: (make-hash-table)
|
| ︙ | | | ︙ | |
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
(hash-table-set!
(dboard:commondat-tabdats commondat)
tabnum
tabdat))
;; create a stuct for all the miscellaneous state
;;
(defstruct dboard:tabdat
allruns
allruns-by-id
buttondat
command
command-tb
|
|
|
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
(hash-table-set!
(dboard:commondat-tabdats commondat)
tabnum
tabdat))
;; data for each specific tab goes here
;;
(defstruct dboard:tabdat
allruns
allruns-by-id
buttondat
command
command-tb
|
| ︙ | | | ︙ | |
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
status-ignore-hash
statuses
target
test-patts
tests
tests-tree
tot-runs
updater-for-runs
)
(define (dboard:tabdat-target-string vec)
(let ((targ (dboard:tabdat-target vec)))
(if (list? targ)(string-intersperse targ "/") "no-target-specified")))
|
>
|
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
status-ignore-hash
statuses
target
test-patts
tests
tests-tree
tot-runs
;; uidat
updater-for-runs
)
(define (dboard:tabdat-target-string vec)
(let ((targ (dboard:tabdat-target vec)))
(if (list? targ)(string-intersperse targ "/") "no-target-specified")))
|
| ︙ | | | ︙ | |
208
209
210
211
212
213
214
215
216
217
218
219
220
221
|
start-test-offset: 0
state-ignore-hash: (make-hash-table)
status-ignore-hash: (make-hash-table)
)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
;; data for runs, tests etc
;;
(defstruct dboard:rundat
;; new system
runs-index ;; target/runname => colnum
tests-index ;; testname/itempath => rownum
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
start-test-offset: 0
state-ignore-hash: (make-hash-table)
status-ignore-hash: (make-hash-table)
)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
(dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
(dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; HACK ALERT: this is a hack, please fix.
(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
(dboard:tabdat-keys-set! tabdat (rmt:get-keys))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
(dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
)
;; data for runs, tests etc
;;
(defstruct dboard:rundat
;; new system
runs-index ;; target/runname => colnum
tests-index ;; testname/itempath => rownum
|
| ︙ | | | ︙ | |
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
|
status: status)))
(sparse-array-set! (dboard:rundat-matrix-dat dat) col-num row-num tdat)
tdat)
#f)))
(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard")))
(define (dboard:setup-tabdat tabdat)
(dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
(dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; HACK ALERT: this is a hack, please fix.
(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
(dboard:tabdat-keys-set! tabdat (rmt:get-keys))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
(dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
285
286
287
288
289
290
291
292
293
294
295
296
297
298
|
status: status)))
(sparse-array-set! (dboard:rundat-matrix-dat dat) col-num row-num tdat)
tdat)
#f)))
(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard")))
(define *exit-started* #f)
;; sorting global data (would apply to many testsuites so leave it global for now)
;;
(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
(vector "Sort -a" 'testname "DESC")
|
| ︙ | | | ︙ | |
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
|
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
(debug:setup)
(define uidat #f)
(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1))
(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))
(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME")))
|
|
|
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
|
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
(debug:setup)
;; (define uidat #f)
(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1))
(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))
(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME")))
|
| ︙ | | | ︙ | |
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
|
(dboard:tabdat-header-set! tabdat header)
(dboard:tabdat-allruns-set! tabdat result)
(debug:print-info 6 *default-log-port* "(dboard:tabdat-allruns tabdat) has " (length (dboard:tabdat-allruns tabdat)) " runs")
maxtests))
(define *collapsed* (make-hash-table))
; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)
(define (toggle-hide lnum) ; fulltestname)
(let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
(fulltestname (iup:attribute btn "TITLE"))
(parts (string-split fulltestname "("))
(basetestname (if (null? parts) "" (car parts))))
;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
(if (hash-table-ref/default *collapsed* basetestname #f)
(begin
|
<
|
|
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
|
(dboard:tabdat-header-set! tabdat header)
(dboard:tabdat-allruns-set! tabdat result)
(debug:print-info 6 *default-log-port* "(dboard:tabdat-allruns tabdat) has " (length (dboard:tabdat-allruns tabdat)) " runs")
maxtests))
(define *collapsed* (make-hash-table))
(define (toggle-hide lnum uidat) ; fulltestname)
(let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
(fulltestname (iup:attribute btn "TITLE"))
(parts (string-split fulltestname "("))
(basetestname (if (null? parts) "" (car parts))))
;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
(if (hash-table-ref/default *collapsed* basetestname #f)
(begin
|
| ︙ | | | ︙ | |
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
|
; #:image img1
; #:impress img2
#:size "x15"
#:expand "HORIZONTAL"
#:fontsize "10"
#:action (lambda (obj)
(mark-for-update tabdat)
(toggle-hide testnum))))) ;; (iup:attribute obj "TITLE"))))
(vector-set! lftcol testnum labl)
(loop (+ testnum 1)(cons labl res))))))
;;
(let loop ((runnum 0)
(keynum 0)
(keyvec (make-vector nkeys))
(res '()))
|
|
|
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
|
; #:image img1
; #:impress img2
#:size "x15"
#:expand "HORIZONTAL"
#:fontsize "10"
#:action (lambda (obj)
(mark-for-update tabdat)
(toggle-hide testnum uidat))))) ;; (iup:attribute obj "TITLE"))))
(vector-set! lftcol testnum labl)
(loop (+ testnum 1)(cons labl res))))))
;;
(let loop ((runnum 0)
(keynum 0)
(keyvec (make-vector nkeys))
(res '()))
|
| ︙ | | | ︙ | |
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
|
(debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(apply max (map (lambda (filen)
(file-modification-time filen))
(glob (conc (dboard:tabdat-dbdir tabdat) "/*.db"))))))
(define (dashboard:run-update x commondat)
(let* ((tabdat (dboard:common-get-tabdat commondat)) ;; uses curr-tab-num
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!!
(monitor-modtime (if (file-exists? monitor-db-path)
(file-modification-time monitor-db-path)
-1))
(run-update-time (current-seconds))
(recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat))))
(if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
(or (> monitor-modtime *last-monitor-update-time*)
(> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
(begin
(set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
(if dashboard:update-servers-table (dashboard:update-servers-table))))
(if recalc
(begin
(case (dboard:commondat-curr-tab-num commondat)
((0)
(if dashboard:update-summary-tab (dashboard:update-summary-tab)))
((1) ;; The runs table is active
(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" "%/%")
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
(let ((res '()))
(for-each (lambda (key)
(if (not (equal? key "runname"))
(let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
(if val (set! res (cons (list key val) res))))))
(dboard:tabdat-dbkeys tabdat))
res))
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
((2)
(dashboard:update-run-summary-tab))
((3)
(dashboard:update-new-view-tab))
(else
(let ((updater (dboard:common-get-tabdat commondat)))
(if updater (updater)))))
(dboard:commondat-please-update-set! commondat #f)
(dboard:tabdat-last-db-update-set! tabdat modtime)
(set! *last-recalc-ended-time* (current-milliseconds))))))
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define (main)
(common:exit-on-version-changed)
(let* (;; (runs-dat (dboard:tabdat-make-data))
;; (runs-sum-dat (dboard:tabdat-make-data)) ;; init (make-d:data))) ;; data for run-summary tab
;; (new-view-dat (dboard:tabdat-make-data)) ;; (dboard:tabdat-make-data)) ;; init (make-d:data)))
(commondat (dboard:commondat-make)))
;; (dboard:tabdat-last-db-update-set! tabdat (file-modification-time (dboard:tabdat-dbfpath tabdat))) ;; (conc *toppath* "/db/main.db")))
;; (set! *monitor-db-path* (conc (dboard:commondat-dbdir commondat) "/monitor.db"))
(set! uidat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data)
;; (dboard:tabdat-numruns tabdat)
;; (dboard:tabdat-num-tests tabdat)
;; (dboard:tabdat-dbkeys tabdat)
;; runs-sum-dat new-view-dat))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
|
|
>
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
|
<
<
|
|
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
|
(debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(apply max (map (lambda (filen)
(file-modification-time filen))
(glob (conc (dboard:tabdat-dbdir tabdat) "/*.db"))))))
(define (dashboard:run-update x commondat)
(let* ((tabdat (dboard:common-get-tabdat commondat))) ;; uses curr-tab-num
(if tabdat ;; if there is no tabdat then likely we are in a test control panel, no update calls needed
(let* ((monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!!
(monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path))
(file-modification-time monitor-db-path)
-1))
(run-update-time (current-seconds))
(uidat (dboard:commondat-uidat commondat))
(recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat))))
(if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
(or (> monitor-modtime *last-monitor-update-time*)
(> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
(begin
(set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
(if dashboard:update-servers-table (dashboard:update-servers-table))))
(if recalc
(begin
(case (dboard:commondat-curr-tab-num commondat)
((0)
(if dashboard:update-summary-tab (dashboard:update-summary-tab)))
((1) ;; The runs table is active
(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" "%/%")
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
(let ((res '()))
(for-each (lambda (key)
(if (not (equal? key "runname"))
(let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
(if val (set! res (cons (list key val) res))))))
(dboard:tabdat-dbkeys tabdat))
res))
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
((2)
(dashboard:update-run-summary-tab))
((3)
(dashboard:update-new-view-tab))
(else
(let ((updater (dboard:common-get-tabdat commondat)))
(if updater (updater)))))
(dboard:commondat-please-update-set! commondat #f)
(dboard:tabdat-last-db-update-set! tabdat modtime)
(set! *last-recalc-ended-time* (current-milliseconds))))))))
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define (main)
(common:exit-on-version-changed)
(let* ((commondat (dboard:commondat-make)))
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
(cond
((args:get-arg "-test") ;; run-id,test-id
(let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
(if (> (length d) 1)
d
(list #f #f))))
(run-id (car dat))
(test-id (cadr dat)))
(if (and (number? run-id)
(number? test-id)
(>= test-id 0))
(examine-test run-id test-id)
(begin
(debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
;; ((args:get-arg "-guimonitor")
;; (gui-monitor (dboard:tabdat-dblocal tabdat)))
(else
(dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data)
;; (dboard:tabdat-numruns tabdat)
;; (dboard:tabdat-num-tests tabdat)
;; (dboard:tabdat-dbkeys tabdat)
;; runs-sum-dat new-view-dat))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
|
| ︙ | | | ︙ | |