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
|
(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 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")
(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
"
))
;; 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"
)
;; switches (don't take arguments)
(list "-h"
"-skip-version-check"
"-repl"
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
|
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
|
(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 commonmod))
(declare (uses commonmod.import))
(import commonmod)
(import 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)))
(if (args:get-arg "-test") ;; need to use tcp for test control panel
(rmt:transport-mode 'tcp))
;; RA => Might require revert for filters
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn")
;; (thread-start! (make-thread common:watchdog "Watchdog thread"))
|
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
|
(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 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
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
422
423
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
|
(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))
;; 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
|
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
|
;; 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)))
(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
)
|
|
|
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
|
;; 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)))
(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
)
|