This is equivalent to a diff from
d69b03fe95
to 11b91c6f65
Modified Makefile
from [0dc94ad098]
to [e1c093b140].
︙ | | |
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
|
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
|
-
+
+
+
+
+
+
+
-
-
-
-
+
+
+
-
-
-
+
+
+
-
+
|
process.scm runs.scm tasks.scm tests.scm genexample.scm \
http-transport.scm filedb.scm tdb.scm client.scm mt.scm \
ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
MSRCFILES =
MSRCFILES = dbmod.scm servermod.scm apimod.scm commonmod.scm rmtmod.scm
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
DMSRCFILES = dcommonmod.scm
DMOFILES = $(addprefix mofiles/,$(DMSRCFILES:%.scm=%.o))
DMOIMPFILES = $(DMSRCFILES:%.scm=%.import.o)
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \
vg.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
%.import.o : %.import.scm
%.import.o : %.import.scm mofiles/%.o
csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary...
# mofiles/%.o %.import.scm : %.scm megatest-fossil-hash.scm
# @[ -e mofiles ] || mkdir -p mofiles
# csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o
# cp $*.o mofiles/$*.o
# @touch $*.import.scm # ensure it is touched after the .o is made
mofiles/%.o : %.scm
# ensure import.scm is touched after the .o is made
#
mofiles/%.o %.import.scm : %.scm
mkdir -p mofiles
csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
@touch $*.import.scm
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
ifeq ($(MTESTHASH),)
|
︙ | | |
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
-
-
+
+
|
mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) megatest-version.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard
dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) $(DMOFILES) $(DMOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) $(DMOFILES) $(DMOIMPFILES) -o dboard
mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
# include makefile.inc
TCMTOBJS = \
|
︙ | | |
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
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
183
184
185
186
187
188
189
|
130
131
132
133
134
135
136
137
138
139
140
141
142
143
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
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
-
+
-
+
-
-
-
+
+
+
+
+
+
-
+
|
tests.o \
subrun.o \
ezsteps.o
# mofiles/rmtmod.o \
# mofiles/commonmod.o \
tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm
tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm $(MOIMPFILES) $(MOFILES)
csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt
# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
mkdir -p $(PREFIX)/share/docs
$(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html
for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done
# add a fake dependency so this doens't copy everytime
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js : # .fslckout
mkdir -p $(PREFIX)/share/js
fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js
$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
mkdir -p $(PREFIX)/share/db
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
# Special dependencies for the includes
# Special dependencies for the module includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
# common.o : mofiles/commonmod.o megatest-fossil-hash.scm
megatest.o : $(MOIMPFILES)
mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/dbmod.o mofiles/servermod.o mofiles/apimod.o mofiles/dcommonmod.o : mofiles/commonmod.o
mofiles/rmtmod.o : mofiles/apimod.o
common.o : mofiles/commonmod.o
# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
tests.o db.o launch.o runs.o dashboard-tests.o \
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
api.o rmt.o : mofiles/apimod.o
megatest.o : megatest-fossil-hash.scm megatest-version.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
common_records.scm : altdb.scm
# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o
vg.o dashboard.o : vg_records.scm megatest-version.scm
dcommon.o : run_records.scm
dcommon.o : mofiles/dcommonmod.o run_records.scm
mofiles/stml2.o : mofiles/cookie.o
# # special include based modules
# mofiles/pkts.o : pkts/pkts.scm
# mofiles/stml2.o : cookie.o
# # mofiles/mtargs.o : mtargs/mtargs.scm
|
︙ | | |
Modified api.scm
from [68ac71805c]
to [3fb38d598d].
︙ | | |
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use srfi-69 posix)
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses tasks))
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
get-var
get-keys
get-key-vals
test-toplevel-num-items
get-test-info-by-id
get-steps-info-by-id
get-data-info-by-id
test-get-rundir-from-test-id
get-count-tests-running-for-testname
get-count-tests-running
get-count-tests-running-in-jobgroup
get-previous-test-run-record
get-matching-previous-test-run-records
test-get-logfile-info
test-get-records-for-index-file
get-testinfo-state-status
test-get-top-process-pid
test-get-paths-matching-keynames-target-new
get-prereqs-not-met
get-count-tests-running-for-run-id
get-run-info
get-run-status
get-run-state
get-run-stats
get-run-times
get-targets
get-target
;; register-run
get-tests-tags
get-test-times
get-tests-for-run
get-tests-for-run-state-status
get-test-id
get-tests-for-runs-mindata
get-tests-for-run-mindata
get-run-name-from-id
get-runs
simple-get-runs
get-num-runs
get-runs-cnt-by-patt
get-all-run-ids
get-prev-run-ids
get-run-ids-matching-target
get-runs-by-patt
get-steps-data
get-steps-for-test
read-test-data
read-test-data*
login
tasks-get-last
testmeta-get-record
have-incompletes?
;; synchash-get
get-changed-record-ids
get-run-record-ids
get-not-completed-cnt))
(declare (uses commonmod))
(define api:write-queries
'(
get-keys-write ;; dummy "write" query to force server start
(import commonmod)
;; SERVERS
start-server
kill-server
;; TESTS
test-set-state-status-by-id
delete-test-records
delete-old-deleted-test-records
test-set-state-status
test-set-top-process-pid
set-state-status-and-roll-up-items
(declare (uses apimod))
update-pass-fail-counts
top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
(import apimod)
;; RUNS
register-run
set-tests-state-status
delete-run
lock/unlock-run
update-run-event_time
mark-incomplete
set-state-status-and-roll-up-run
;; STEPS
teststep-set-status!
delete-steps-for-test
;; TEST DATA
test-data-rollup
csv->test-data
;; MISC
sync-inmem->db
drop-all-triggers
create-all-triggers
update-tesdata-on-repilcate-db
;; TESTMETA
testmeta-add-record
testmeta-update-field
;; TASKS
tasks-add
tasks-set-state-given-param-key
))
;; These are called by the server on recipt of /api calls
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;; - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
|
︙ | | |
Modified apimod.scm
from [0c866deee4]
to [8bd7a90a17].
︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
|
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit apimod))
(declare (uses commonmod))
(declare (uses ulex))
;; (declare (uses ulex))
(module apimod
*
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
(import (prefix ulex ulex:))
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
get-var
get-keys
get-key-vals
test-toplevel-num-items
get-test-info-by-id
get-steps-info-by-id
get-data-info-by-id
test-get-rundir-from-test-id
get-count-tests-running-for-testname
get-count-tests-running
get-count-tests-running-in-jobgroup
get-previous-test-run-record
get-matching-previous-test-run-records
test-get-logfile-info
test-get-records-for-index-file
get-testinfo-state-status
test-get-top-process-pid
test-get-paths-matching-keynames-target-new
get-prereqs-not-met
get-count-tests-running-for-run-id
get-run-info
get-run-status
get-run-state
get-run-stats
get-run-times
get-targets
get-target
;; register-run
get-tests-tags
get-test-times
get-tests-for-run
get-tests-for-run-state-status
get-test-id
get-tests-for-runs-mindata
get-tests-for-run-mindata
get-run-name-from-id
get-runs
simple-get-runs
get-num-runs
get-runs-cnt-by-patt
get-all-run-ids
get-prev-run-ids
get-run-ids-matching-target
get-runs-by-patt
get-steps-data
get-steps-for-test
read-test-data
read-test-data*
login
tasks-get-last
testmeta-get-record
have-incompletes?
;; synchash-get
get-changed-record-ids
get-run-record-ids
get-not-completed-cnt))
(define api:write-queries
'(
get-keys-write ;; dummy "write" query to force server start
;; SERVERS
start-server
kill-server
;; TESTS
test-set-state-status-by-id
delete-test-records
delete-old-deleted-test-records
test-set-state-status
test-set-top-process-pid
set-state-status-and-roll-up-items
update-pass-fail-counts
top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
;; RUNS
register-run
set-tests-state-status
delete-run
lock/unlock-run
update-run-event_time
mark-incomplete
set-state-status-and-roll-up-run
;; STEPS
teststep-set-status!
delete-steps-for-test
;; TEST DATA
test-data-rollup
csv->test-data
;; MISC
sync-inmem->db
drop-all-triggers
create-all-triggers
update-tesdata-on-repilcate-db
;; TESTMETA
testmeta-add-record
testmeta-update-field
;; TASKS
tasks-add
(define (api:execute-requests params)
#f)
tasks-set-state-given-param-key
))
)
|
Modified archive.scm
from [a5f3e3b4ad]
to [0a572a4ddb].
︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
+
+
+
|
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
(declare (unit archive))
(declare (uses db))
(declare (uses common))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
;;======================================================================
;;
;;======================================================================
|
︙ | | |
Modified client.scm
from [dc4c7b41e8]
to [cecbbc9d00].
︙ | | |
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
+
+
+
|
spiffy-request-vars uri-common intarweb directory-utils)
(declare (unit client))
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
;; client:get-signature
(define (client:get-signature)
(if *my-client-signature* *my-client-signature*
|
︙ | | |
Modified common.scm
from [bf0a0a25ad]
to [f8fa1c917f].
︙ | | |
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
|
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
|
-
-
+
+
+
+
+
+
+
+
+
+
+
|
matchable regex posix (srfi 18) extras ;; tcp
(prefix nanomsg nmsg:)
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
)
(declare (unit common))
;; (declare (uses commonmod))
;; (import commonmod)
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
;; (define old-exit exit)
;;
;; (define (exit . code)
;; (if (null? code)
;; (old-exit)
;; (old-exit code)))
(define (common:debug-setup)
(debug:setup (cond ;; debug arg
((args:get-arg "-debug-noprop") 'noprop)
((args:get-arg "-debug") #t)
(else #f))
(cond ;; verbosity arg
((args:get-arg "-q") 'v)
((args:get-arg "-q") 'q)
(else #f))))
;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; arguments - thunk, message
(define (common:fail-safe thunk warning-message-on-exception)
(handle-exceptions
exn
(begin
|
︙ | | |
801
802
803
804
805
806
807
808
809
810
811
812
813
814
|
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
|
+
+
+
+
+
+
|
(6 "CHECK")
(7 "STUCK/DEAD")
(8 "DEAD")
(9 "FAIL")
(10 "PREQ_FAIL")
(11 "PREQ_DISCARDED")
(12 "ABORT")))
(define (common:status>? s1 s2)
(let* ((munged (map (lambda (x) `(,(cadr x) . ,(car x))) *common:std-statuses*))
(v1 (alist-ref s1 munged equal?))
(v2 (alist-ref s2 munged equal?)))
(> v1 v2)))
(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed
'("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" ))
(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
'("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD"))
|
︙ | | |
Modified common_records.scm
from [80f9e14f2d]
to [e4251bc312].
︙ | | |
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
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
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
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
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
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
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
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
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
|
;;
(define-inline (with-mutex mtx accessor record . val)
(mutex-lock! mtx)
(let ((res (apply accessor record val)))
(mutex-unlock! mtx)
res))
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
;; ;; this was cached based on results from profiling but it turned out the profiling
;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; ;; in for now but can probably take it out later.
;; ;;
;; (define (debug:calc-verbosity vstr)
;; (or (hash-table-ref/default *verbosity-cache* vstr #f)
;; (let ((res (cond
;; ((number? vstr) vstr)
;; ((not (string? vstr)) 1)
;; ;; ((string-match "^\\s*$" vstr) 1)
;; (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
;; (cond
;; ((> (length debugvals) 1) debugvals)
;; ((> (length debugvals) 0)(car debugvals))
;; (else 1))))
;; ((args:get-arg "-v") 2)
;; ((args:get-arg "-q") 0)
;; (else 1))))
;; (hash-table-set! *verbosity-cache* vstr res)
;; res)))
;;
(define (debug:calc-verbosity vstr)
(or (hash-table-ref/default *verbosity-cache* vstr #f)
(let ((res (cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
((args:get-arg "-v") 2)
((args:get-arg "-q") 0)
(else 1))))
(hash-table-set! *verbosity-cache* vstr res)
res)))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
(define (debug:debug-mode n)
(cond
((and (number? *verbosity*) ;; number number
(number? n))
(<= n *verbosity*))
((and (list? *verbosity*) ;; list number
(number? n))
(member n *verbosity*))
((and (list? *verbosity*) ;; list list
(list? n))
(not (null? (lset-intersection! eq? *verbosity* n))))
((and (number? *verbosity*)
(list? n))
(member *verbosity* n))))
(define (debug:setup)
(let ((debugstr (or (args:get-arg "-debug")
(args:get-arg "-debug-noprop")
(getenv "MT_DEBUG_MODE"))))
(set! *verbosity* (debug:calc-verbosity debugstr))
(debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not *verbosity*)(set! *verbosity* 1))
(if (and (not (args:get-arg "-debug-noprop"))
(or (args:get-arg "-debug")
(not (getenv "MT_DEBUG_MODE"))))
(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
(string-intersperse (map conc *verbosity*) ",")
(conc *verbosity*))))))
(define (debug:print n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if *logging*
(db:log-event (apply conc params))
(apply print params)
)))))
;; Brandon's debug printer shortcut (indulge me :)
(define *BB-process-starttime* (current-milliseconds))
(define (BB> . in-args)
(let* ((stack (get-call-chain))
(location "??"))
(for-each
(lambda (frame)
(let* ((this-loc (vector-ref frame 0))
(temp (string-split (->string this-loc) " "))
(this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
(if (equal? this-func "BB>")
(set! location this-loc))))
stack)
(let* ((color-on "\x1b[1m")
(color-off "\x1b[0m")
(dp-args
(append
(list 0 *default-log-port*
(conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
in-args)))
(apply debug:print dp-args))))
(define *BBpp_custom_expanders_list* (make-hash-table))
;; register hash tables with BBpp.
(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
(cons hash-table? hash-table->alist))
;; test name converter
(define (BBpp_custom_converter arg)
(let ((res #f))
(for-each
(lambda (custom-type-name)
(let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
(custom-type-test (car custom-type-info))
(custom-type-converter (cdr custom-type-info)))
(when (and (not res) (custom-type-test arg))
(set! res (custom-type-converter arg)))))
(hash-table-keys *BBpp_custom_expanders_list*))
(if res (BBpp_ res) arg)))
(define (BBpp_ arg)
(cond
;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
((hash-table? arg)
(let ((al (hash-table->alist arg)))
(BBpp_ (cons HASH_TABLE: al))))
((null? arg) '())
;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
(else (BBpp_custom_converter arg))))
;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
(define (BBpp arg)
(pp (BBpp_ arg)))
;(use define-macro)
(define-syntax inspect
(syntax-rules ()
[(_ x)
;; (with-output-to-port (current-error-port)
(printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;; )
;; ;; check verbosity, #t is ok
;; (define (debug:check-verbosity verbosity vstr)
;; (if (not (or (number? verbosity)
;; (list? verbosity)))
;; (begin
;; (print "ERROR: Invalid debug value \"" vstr "\"")
;; #f)
;; #t))
;;
;; (define (debug:debug-mode n)
;; (cond
;; ((and (number? *verbosity*) ;; number number
;; (number? n))
;; (<= n *verbosity*))
;; ((and (list? *verbosity*) ;; list number
;; (number? n))
;; (member n *verbosity*))
;; ((and (list? *verbosity*) ;; list list
;; (list? n))
;; (not (null? (lset-intersection! eq? *verbosity* n))))
;; ((and (number? *verbosity*)
;; (list? n))
;; (member *verbosity* n))))
;;
;; (define (debug:setup)
;; (let ((debugstr (or (args:get-arg "-debug")
;; (args:get-arg "-debug-noprop")
;; (getenv "MT_DEBUG_MODE"))))
;; (set! *verbosity* (debug:calc-verbosity debugstr))
;; (debug:check-verbosity *verbosity* debugstr)
;; ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
;; (if (not *verbosity*)(set! *verbosity* 1))
;; (if (and (not (args:get-arg "-debug-noprop"))
;; (or (args:get-arg "-debug")
;; (not (getenv "MT_DEBUG_MODE"))))
;; (setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
;; (string-intersperse (map conc *verbosity*) ",")
;; (conc *verbosity*))))))
;;
;; (define (debug:print n e . params)
;; (if (debug:debug-mode n)
;; (with-output-to-port (or e (current-error-port))
;; (lambda ()
;; (if *logging*
;; (db:log-event (apply conc params))
;; (apply print params)
;; )))))
;;
;; ;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
;; (define (BB> . in-args)
;; (let* ((stack (get-call-chain))
;; (location "??"))
;; (for-each
;; (lambda (frame)
;; (let* ((this-loc (vector-ref frame 0))
;; (temp (string-split (->string this-loc) " "))
;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;; (if (equal? this-func "BB>")
;; (set! location this-loc))))
;; stack)
;; (let* ((color-on "\x1b[1m")
;; (color-off "\x1b[0m")
;; (dp-args
;; (append
;; (list 0 *default-log-port*
;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
;; in-args)))
;; (apply debug:print dp-args))))
;;
;; (define *BBpp_custom_expanders_list* (make-hash-table))
;;
;;
;;
;; ;; register hash tables with BBpp.
;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;; (cons hash-table? hash-table->alist))
;;
;; ;; test name converter
;; (define (BBpp_custom_converter arg)
;; (let ((res #f))
;; (for-each
;; (lambda (custom-type-name)
;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;; (custom-type-test (car custom-type-info))
;; (custom-type-converter (cdr custom-type-info)))
;; (when (and (not res) (custom-type-test arg))
;; (set! res (custom-type-converter arg)))))
;; (hash-table-keys *BBpp_custom_expanders_list*))
;; (if res (BBpp_ res) arg)))
;;
;; (define (BBpp_ arg)
;; (cond
;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;; ((hash-table? arg)
;; (let ((al (hash-table->alist arg)))
;; (BBpp_ (cons HASH_TABLE: al))))
;; ((null? arg) '())
;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;; (else (BBpp_custom_converter arg))))
;;
;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
;; (define (BBpp arg)
;; (pp (BBpp_ arg)))
;;
;; ;(use define-macro)
;; (define-syntax inspect
;; (syntax-rules ()
;; [(_ x)
;; ;; (with-output-to-port (current-error-port)
;; (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;; ;; )
;; ]
]
[(_ x y ...) (begin (inspect x) (inspect y ...))]))
(define (debug:print-error n e . params)
;; normal print
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(if *logging*
(db:log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
(apply print "ERROR: " params)
))))
;; pass important messages to stderr
(if (and (eq? n 0)(not (eq? e (current-error-port))))
(with-output-to-port (current-error-port)
(lambda ()
(apply print "ERROR: " params)
))))
(define (debug:print-info n e . params)
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(if *logging*
(let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
(db:log-event res))
;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
(apply print "INFO: (" n ") " params) ;; res)
)))))
;; [(_ x y ...) (begin (inspect x) (inspect y ...))]))
;;
;; (define (debug:print-error n e . params)
;; ;; normal print
;; (if (debug:debug-mode n)
;; (with-output-to-port (if (port? e) e (current-error-port))
;; (lambda ()
;; (if *logging*
;; (db:log-event (apply conc params))
;; ;; (apply print "pid:" (current-process-id) " " params)
;; (apply print "ERROR: " params)
;; ))))
;; ;; pass important messages to stderr
;; (if (and (eq? n 0)(not (eq? e (current-error-port))))
;; (with-output-to-port (current-error-port)
;; (lambda ()
;; (apply print "ERROR: " params)
;; ))))
;;
;; (define (debug:print-info n e . params)
;; (if (debug:debug-mode n)
;; (with-output-to-port (if (port? e) e (current-error-port))
;; (lambda ()
;; (if *logging*
;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
;; (db:log-event res))
;; ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
;; (apply print "INFO: (" n ") " params) ;; res)
;; )))))
;;
;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
(if (or (number? val)(string? val)) val ""))
|
Modified commonmod.scm
from [9423abd515]
to [7ea60c4771].
︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
-
+
-
+
+
|
;;======================================================================
(declare (unit commonmod))
(module commonmod
*
(import scheme chicken data-structures extras files)
(import scheme chicken data-structures extras files ports)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
md5 message-digest
regex srfi-1)
regex srfi-1
format)
;;======================================================================
;; CONTENTS
;;
;; config file utils
;; misc conversion, data manipulation functions
;; testsuite and area utilites
|
︙ | | |
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
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
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
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
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;
(define (get-cfg-areas cfgdat)
(let ((adat (get-section cfgdat "areas")))
(map (lambda (entry)
`(,(car entry) .
,(val->alist (cadr entry))))
adat)))
;;======================================================================
;; debug stuff
;;======================================================================
(define verbosity (make-parameter '()))
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
;; (set! debug:print dbgp)
;; (set! debug:print-info dbgpinfo))
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
(let* ((res (cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
((eq? arg 'v) 2) ;; verbose
((eq? arg 'q) 0) ;; quiet
(else 1))))
(verbosity res)
res))
)
;; check verbosity, #t is ok
#;(define (debug-check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
(define (debug:debug-mode n)
(let* ((vb (verbosity)))
(cond
((and (number? vb) ;; number number
(number? n))
(<= n vb))
((and (list? vb) ;; list number
(number? n))
(member n vb))
((and (list? vb) ;; list list
(list? n))
(not (null? (lset-intersection! eq? vb n))))
((and (number? vb)
(list? n))
(member vb n)))))
(define (debug:setup debug-arg verbose-arg) ;; debug-arg= #f, #t or 'noprop
(let ((debugstr (or debug-arg ;; (args:get-arg "-debug")
;; (args:get-arg "-debug-noprop")
(get-environment-variable "MT_DEBUG_MODE"))))
(debug:calc-verbosity debugstr verbose-arg)
;; (debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not (verbosity))(set! (verbosity) 1))
(if (and (not (eq? debug-arg 'noprop))
(or debug-arg
(not (get-environment-variable "MT_DEBUG_MODE"))))
(setenv "MT_DEBUG_MODE" (if (list? (verbosity))
(string-intersperse (map conc (verbosity)) ",")
(conc (verbosity)))))))
(define (debug:print n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
;; (if *logging*
;; (db:log-event (apply conc params))
(apply print params)
)))) ;; )
(define (debug:print-error n e . params)
;; normal print
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(apply print "ERROR: " params)
)))
;; pass important messages to stderr
(if (and (eq? n 0)(not (eq? e (current-error-port))))
(with-output-to-port (current-error-port)
(lambda ()
(apply print "ERROR: " params)
))))
(define (debug:print-info n e . params)
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(apply print "INFO: (" n ") " params) ;; res)
))))
)
|
Modified configf.scm
from [b115fef76f]
to [fb6d9bbd39].
︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
+
+
+
|
;;======================================================================
(use regex regex-case matchable) ;; directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
(if toppath
(let ((cfname (conc toppath "/" configname)))
|
︙ | | |
Modified dashboard-context-menu.scm
from [48947370a7]
to [4ebbf2ae46].
︙ | | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
+
+
+
|
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(define (dboard:launch-testpanel run-id test-id)
(let* ((dboardexe (common:find-local-megatest "dashboard"))
|
︙ | | |
Modified dashboard-guimonitor.scm
from [9920d4908c]
to [8b202da860].
︙ | | |
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
+
+
+
|
(import (prefix sqlite3 sqlite3:))
(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses db))
(declare (uses tasks))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(define (control-panel db tdb keys)
|
︙ | | |
Modified dashboard-tests.scm
from [237d160a6c]
to [0de4378c1e].
︙ | | |
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
+
+
+
|
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
;;======================================================================
;; C O M M O N
|
︙ | | |
Modified dashboard.scm
from [935bf4d2df]
to [81d3b13df4].
︙ | | |
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
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
|
+
+
+
+
+
+
+
+
-
+
|
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))
(declare (uses commonmod))
(import commonmod)
(declare (uses commonmod.import))
(declare (uses dcommonmod))
(import dcommonmod)
(declare (uses dcommonmod.import))
(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 "megatest-fossil-hash.scm")
(include "vg_records.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2017
|
︙ | | |
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn")
;; (if (not (args:get-arg "-use-db-cache"))
;; (begin
;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;)
;;)
;; data common to all tabs goes here
;; data common to all tabs in dboard:commondat struct moved to dcommonmod
;;
(defstruct dboard:commondat
((curr-tab-num 0) : number)
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)
please-update: #t
update-mutex: (make-mutex)
updaters: (make-hash-table)
updating: #f
hide-not-hide-tabs: #f
))
;; 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
|
︙ | | |
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
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
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
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
434
435
436
437
438
439
440
441
442
443
444
|
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
(let* ((tnum (or tab-num
(dboard:commondat-curr-tab-num commondat)))
(curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
(hash-table-set! (dboard:commondat-updaters commondat)
tnum
(cons updater curr-updaters))))
;; data for each specific tab goes here
;;
(defstruct dboard:tabdat
;; 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")
(configf:lookup *configdat* "dashboard" "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
;; Runs view
((buttondat (make-hash-table)) : hash-table) ;;
((item-test-names '()) : list) ;; list of itemized tests
((run-keys (make-hash-table)) : hash-table)
(runs-matrix #f) ;; used in newdashboard
((start-run-offset 0) : number) ;; left-right slider value
((start-test-offset 0) : number) ;; up-down slider value
((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
((all-test-names '()) : list)
;; Canvas and drawing data
(cnv #f)
(cnv-obj #f)
(drawing #f)
((run-start-row 0) : number)
((max-row 0) : number)
((running-layout #f) : boolean)
(originx #f)
(originy #f)
((layout-update-ok #t) : boolean)
((compact-layout #t) : boolean)
;; Run times layout
;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
(graph-matrix #f)
((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
((graph-matrix-row 1) : number)
((graph-matrix-col 1) : number)
;; Controls used to launch runs etc.
((command "") : string) ;; for run control this is the command being built up
(command-tb #f) ;; widget for the type of command; run, remove-runs etc.
(test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
(key-listboxes #f)
(key-lbs #f)
run-name ;; from run name setting widget
states ;; states for -state s1,s2 ...
statuses ;; statuses for -status s1,s2 ...
;; Selector variables
curr-run-id ;; current row to display in Run summary view
prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
((hide-empty-runs #f) : boolean)
((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
(hide-not-hide-button #f)
((searchpatts (make-hash-table)) : hash-table) ;;
((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
(target #f)
(test-patts #f)
;; db info to file the .db files for the area
(access-mode (db:get-access-mode)) ;; use cached db or not
(dbdir #f)
(dbfpath #f)
(dbkeys #f)
((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
(monitor-db-path #f) ;; where to find monitor.db
ro ;; is the database read-only?
;; tests data
((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
;; runs tree
((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
(runs-tree #f)
((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
;; tab data
((view-changed #t) : boolean)
((xadj 0) : number) ;; x slider number (if using canvas)
((yadj 0) : number) ;; y slider number (if using canvas)
;; runs-summary tab state
((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
((runs-summary-mode-buttons '()) : list)
((runs-summary-mode 'one-run) : symbol)
((runs-summary-mode-change-callbacks '()) : list)
(runs-summary-source-runname-label #f)
(runs-summary-dest-runname-label #f)
;; runs summary view
tests-tree ;; used in newdashboard
)
;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
(cons dboard:tabdat?
(lambda (tabdat-item)
(filter
(lambda (alist-entry)
(member (car alist-entry)
'(allruns-by-id allruns))) ;; FIELDS OF INTEREST
(dboard:tabdat->alist tabdat-item)))))
(define (dboard:tabdat-target-string vec)
(let ((targ (dboard:tabdat-target vec)))
(if (list? targ)(string-intersperse targ "/") "no-target-specified")))
(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:tabdat-runs-btn-height-set! dat (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) ;; was 12
(dboard:tabdat-runs-btn-fontsz-set! dat (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) ;; was 8
(dboard:tabdat-runs-cell-width-set! dat (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) ;; was 50
(dboard:tabdat-numruns-set! dat (string->number (or (args:get-arg "-cols")
(configf:lookup *configdat* "dashboard" "cols")
"8")))
(dboard:tabdat-access-mode-set! dat (db:get-access-mode)) ;; use cached db or not
(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.
(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 "%"))
)
;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
((id #f) : string)
((color #f) : vector)
((flag #t) : boolean)
((cell #f) : number)
)
;; data for runs, tests etc. was used in run summary?
;;
(defstruct dboard:runsdat
;; new system
runs-index ;; target/runname => colnum
tests-index ;; testname/itempath => rownum
matrix-dat ;; vector of vectors rows/cols
)
(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 megatest.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
;; view related items
|
︙ | | |
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
|
331
332
333
334
335
336
337
338
339
340
341
342
343
344
|
-
-
-
-
-
-
-
-
-
-
-
-
-
|
runid
testname ;; test[/itempath]
state
status
start-time
duration
)
;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
(cons dboard:rundat?
(lambda (tabdat-item)
(filter
(lambda (alist-entry)
(member (car alist-entry)
'(run run-data-offset ))) ;; FIELDS OF INTEREST
(dboard:rundat->alist tabdat-item)))))
(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
(make-dboard:rundat
run: run
tests: (or tests (make-hash-table))
key-vals: key-vals
|
︙ | | |
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
|
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
|
-
+
|
(if t-sort
(cadr t-sort)
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
(debug:setup)
(common: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))
|
︙ | | |
Modified db.scm
from [f2d817bbad]
to [403e3c3554].
︙ | | |
31
32
33
34
35
36
37
38
39
40
41
42
43
44
|
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
+
+
+
|
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
|
︙ | | |
Modified dcommon.scm
from [dbcf309f44]
to [35ed13ca5b].
︙ | | |
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
+
+
+
+
+
+
+
|
(import canvas-draw-iup)
(use regex typed-records matchable)
(declare (unit dcommon))
(declare (uses gutils))
(declare (uses db))
(declare (uses commonmod))
(import commonmod)
(declare (uses dcommonmod))
(import dcommonmod)
;; (declare (uses synchash))
(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
|
︙ | | |
Added dcommonmod.scm version [751a530ad5].