| ︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
|
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(import dbfile)
(declare (uses margs))
(declare (uses mtargs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))
(declare (uses configf))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
(declare (uses mt))
(declare (uses dbmod))
;; (declare (uses dbmemmod))
(declare (uses dbfile))
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses commonmod.import))
(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup
(prefix sqlite3 sqlite3:))
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import commonmod
(prefix mtargs args:)
dbmod
dbfile)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
;; set some parameters here - these need to be put in something that can be loaded from other
;; executables such as dashboard and mtutil
;;
(include "dashboard-transport-mode.scm")
(dbfile:db-init-proc db:initialize-main-db)
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version
" license GPL, Copyright (C) Matt Welland 2012-2017
Usage: dashboard [options]
-h : this help
-test run-id test-id : open a test control panel on this test
-skip-version-check : skip the version check
-rows R : set number of rows
-cols C : set number of columns
-start-dir dir : start dashboard in the given directory
-target target : filter runs tab to given target.
-debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9
-repl : Start a chicken scheme interpreter
-mode MODE : tcp or nfs
"
))
;; process args
(define remargs (args:get-args
(argv)
;; parameters (need arguments)
(list "-rows"
"-cols"
"-test" ;; given a run id and test id, open only a test control panel on that test..
"-debug"
"-start-dir"
"-target"
"-mode" ;; tcp or nfs
)
;; switches (don't take arguments)
(list "-h"
"-skip-version-check"
"-repl"
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
(if (args:get-arg "-mode")
(let* ((mode (string->symbol (args:get-arg "-mode"))))
(rmt:transport-mode mode)))
|
| ︙ | | |
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
-
+
|
(dboard:commondat-tabdats commondat)
tabnum
tabdat))
;; gets and calls updater list based on curr-tab-num
;;
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
(sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num))
;; (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) ;; no longer applies
(if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
(let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat)))
(updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
tnum
'())))
(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
(for-each ;; perform the function calls for the complete updaters list
|
| ︙ | | |
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
|
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
|
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(define (dboard:runsdat-make-init)
(make-dboard:runsdat
runs-index: (make-hash-table)
tests-index: (make-hash-table)
matrix-dat: (make-sparse-array)))
;; duplicated in dcommon.scm
;;
;; used to keep the rundata from rmt: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
hierdat ;; put hierarchial sorted list here
tests ;; hash of id => testdat
((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
key-vals
((last-update 0) : number) ;; last query to db got records from before last-update
((last-db-time 0) : number) ;; last timestamp on main.db
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
(db-path #f))
;; ;; used to keep the rundata from rmt: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
;; hierdat ;; put hierarchial sorted list here
;; tests ;; hash of id => testdat
;; ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
;; key-vals
;; ((last-update 0) : number) ;; last query to db got records from before last-update
;; ((last-db-time 0) : number) ;; last timestamp on main.db
;; ((data-changed #f) : boolean)
;; ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
;; (db-path #f))
;; for the new runs view lets build up a few new record types and then consolidate later
;;
;; this is a two level deep pipeline for the incoming data:
;; sql query data ==> filters ==> data for display
;;
(defstruct dboard:rdat
|
| ︙ | | |
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
|
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
|
-
-
+
+
|
;;(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/main.db")))
(let* ((db-dir (get-environment-variable "MT_RUN_AREA_HOME")) ;; (common:get-db-tmp-area))
(db-pth (conc db-dir "/.mtdb/main.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)
|
| ︙ | | |
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
|
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
|
-
+
|
;; optimized to get runs constrained by what is visible on the screen
;; - not appropriate for where all the runs are needed
;;
(define (update-buttons tabdat uidat numruns numtests)
(let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns)
(take-right (dboard:tabdat-allruns tabdat) numruns)
(pad-list (dboard:tabdat-allruns tabdat) numruns)))
(pad-list (dboard:tabdat-allruns tabdat) numruns)))
(lftcol (dboard:uidat-get-lftcol uidat))
(tableheader (dboard:uidat-get-header uidat))
(table (dboard:uidat-get-runsvec uidat))
(coln 0)
(all-test-names (make-hash-table))
(use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")) ;; doesn't work
)
|
| ︙ | | |
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
|
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
|
-
+
|
;;======================================================================
(stop-the-train)
(define (main)
;; (print "Starting dashboard main")
(let* ((mtdb-path (conc *toppath* "/.megatest/main.db"))
(let* ((mtdb-path (conc *toppath* "/.mtdb/main.db"))
(target (args:get-arg "-target"))
(commondat (dboard:commondat-make)))
(if target
(begin
(args:remove-arg-from-ht "-target")
(dboard:commondat-target-set! commondat target)
)
|
| ︙ | | |