1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
-
+
-
-
-
|
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
(use format numbers)
(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))
|
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
|
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
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
|
+
+
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
(define (update-search x val)
(hash-table-set! *searchpatts* x val))
;;======================================================================
;; R E C O R D S
;;======================================================================
;; NOTE: Consider switching to defstruct.
;; data for an area (regression or testsuite)
;;
(define-record area
(define-record areadat
name ;; area name
path ;; mt run area home
configdat ;; megatest config
denoise ;; focal point for not putting out same messages over and over
client-signature ;; key for client-server conversation
remote ;; hash of all the client side connnections
run-keys ;; target keys for this area
rundat ;; used in dashboard
runs ;; used in dashboard, hash of run-ids -> rundat
read-only ;; can I write to this area?
monitordb ;; db handle for monitor.db
maindb ;; db handle for main.db
)
;; rundat, basic run data
;;
(define-record rundat
id ;; the run-id
target ;; val1/val2 ... corrosponding to run-keys in areadat
runname
state ;; state of the run, symbol
status ;; status of the run, symbol
event-time ;; when the run was initiated
tests ;; hash of test-id -> testdat, QUESTION: separate by run-id?
db ;; db handle
)
;; testdat, basic test data
(define-record testdat
run-id ;; what run is this from
id ;; test id
state ;; test state, symbol
status ;; test status, symbol
event-time ;; when the test started
duration ;; how long the test took
)
;; general data for the dboard application
;;
(define-record data
cfgdat ;; data from ~/.megatest/<group>.dat
areas ;; hash of areaname -> area-rec
current-window-id ;;
current-tab-id ;;
update-needed ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately
tab-ids ;; hash of tab-id -> areaname
)
;; all the components of an area display, all fits into a tab but
;; parts may be swapped in/out as needed
;;
(define-record tab
tree
matrix ;; the spreadsheet
area-dat ;; the one-structure (one day dbstruct will be put in here)
areadat ;; the one-structure (one day dbstruct will be put in here)
view-path ;; <target/path>/<runname>/...
view-type ;; standard, etc.
controls ;; the controls
data ;; all the data kept in sync with db
filters ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/<group>.dat?
run-id ;; the current run-id
test-ids ;; the current test id hash, run-id => test-id
command ;; the command from the entry field
)
(define-record filter
target ;; hash of widgets for the target
runname ;; the runname widget
testpatt ;; the testpatt widget
)
;;======================================================================
;; D B
;;======================================================================
;; These are all using sqlite and independent of area so cannot use stuff
;; from db.scm
;; NB// run-id=#f => return dbdir only
;;
(define (areadb:dbfile-path areadat run-id)
(let* ((cfgdat (areadat-configdat areadat))
(dbdir (or (configf:lookup cfgdat "setup" "dbdir")
(conc (configf:lookup cfgdat "setup" "linktree") "/.db")))
(fname (if run-id
(case run-id
((-1) "monitor.db")
((0) "main.db")
(else (conc run-id ".db")))
#f)))
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Couldn't create path to " dbdir)
(exit 1))
(if (not (directory? dbdir))(create-directory dbdir #t)))
(if fname
(conc dbdir "/" fname)
dbdir)))
;; -1 => monitor.db
;; 0 => main.db
;; >1 => <run-id>.db
;;
(define (areadb:open areadat run-id)
(let* ((runs (areadat-runs areadat))
(rundat (if (> run-id 0) ;; it is a run
(hash-table-ref/default runs run-id #f)
#f))
(db (case run-id ;; if already opened, get the db and return it
((-1) (areadat-monitordb areadat))
((0) (areadat-maindb areadat))
(else (if run
(rundat-db rundat)
#f)))))
(if db
db ;; merely return the already opened db
(let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it
(db (if (file-exists? dbfile)
(open-database dbfile)
(begin
(debug:print 0 "ERROR: I was asked to open " dbfile ", but file does not exist or is not readable.")
#f))))
(case run-id
((-1)(areadat-monitordb-set! areadat db))
((0) (areadat-maindb-set! areadat db))
(else (rundat-db-set! rundat db)))
db))))
;; populate the areadat tests info, does NOT fill the tests data itself
;;
(define (areadb:populate-run-info areadat)
(let* ((runs (or (areadat-tests areadat) (make-hash-table)))
(keys (areadat-run-keys areadat))
(maindb (areadb:open areadat 0)))
(query (for-each-row (lambda (row)
(let ((id (list-ref row 0))
(dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db
(hash-table-set! runs id dat)))
(sql maindb (conc "SELECT id,"
(string-intersperse keys "'||/||'")
",runname,state,status,event_time FROM runs WHERE state != 'DELETED';"))))
areadat))
;;======================================================================
;; T R E E
;;======================================================================
;; <area> - <target - ... > - <runname> - <test> - <itempath - ...>
(define (dashboard:tree-browser data adat window-id)
;; (iup:split
(let* ((tb (iup:treebox
#:selection-cb
(lambda (obj id state)
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((tree-path (tree:node->path obj id))
(area (car tree-path))
(area-path (cdr tree-path)))
(areadat-path (cdr tree-path)))
#f
;; (test-id (tree-path->test-id (cdr run-path))))
;; (if test-id
;; (hash-table-set! (dboard:data-get-curr-test-ids *data*)
;; window-id test-id))
;; (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
)))))
|
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
|
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
|
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
view-matrix)))))
;;======================================================================
;; A R E A S
;;======================================================================
(define (dashboard:init-area data area-name apath)
(let* ((mtconffile (conc area-name "/megatest.config"))
(let* ((mtconffile (conc apath "/megatest.config"))
(mtconf (read-config mtconffile (make-hash-table) #f)) ;; megatest.config
(area-dat (let ((ad (make-area
area-name ;; area name
apath ;; path to area
;; 'http ;; transport
mtconf ;; megatest.config
(make-hash-table) ;; denoise hash
#f ;; client-signature
#f ;; remote connections
#f ;; run keys
(make-hash-table) ;; run-id -> (hash of test-ids => dat)
(and (file-exists? apath)(file-write-access? apath)) ;; read-only
)))
(hash-table-set! (data-areas data) area-name ad)
ad)))
(area-dat (let ((ad (make-areadat
area-name ;; area name
apath ;; path to area
;; 'http ;; transport
mtconf ;; megatest.config
(make-hash-table) ;; denoise hash
#f ;; client-signature
#f ;; remote connections
#f ;; run keys
(make-hash-table) ;; run-id -> (hash of test-ids => dat)
(and (file-exists? apath)(file-write-access? apath)) ;; read-only
#f
#f
)))
(hash-table-set! (data-areas data) area-name ad)
ad)))
area-dat))
;;======================================================================
;; D A S H B O A R D
;;======================================================================
(define (dashboard:area-panel aname data window-id)
|