| ︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
+
|
(use canvas-draw)
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(include "common.scm")
(include "margs.scm")
(include "keys.scm")
(include "items.scm")
(include "db.scm")
(include "configf.scm")
(include "process.scm")
(include "launch.scm")
|
| ︙ | | |
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
+
+
+
|
;; process args
(define remargs (args:get-args
(argv)
(list "-rows"
"-run"
"-test"
"-debug"
)
(list "-h"
"-v"
"-q"
)
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
(print help)
|
| ︙ | | |
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
+
+
+
+
+
+
|
(define *num-runs* 10)
(define *num-tests* 15)
(define *start-run-offset* 0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *verbosity* (cond
((args:get-arg "-debug")(string->number (args:get-arg "-debug")))
((args:get-arg "-v") 2)
((args:get-arg "-q") 0)
(else 1)))
(define (message-window msg)
(iup:show
(iup:dialog
(iup:vbox
(iup:label msg #:margin "40x40")))))
(define (iuplistbox-fill-list lb items . default)
|
| ︙ | | |
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
+
+
+
+
+
+
|
(set! maxtests (length tests)))
(set! result (cons (vector run tests key-vals) result))))
runs)
(set! *header* header)
(set! *allruns* result)
maxtests))
(define *collapsed* (make-hash-table))
(define (toggle-hide testname)
(if (hash-table-ref/default *collapsed* testname #f)
(hash-table-delete! *collapsed* testname)
(hash-table-set! *collapsed* testname #t)))
(define (update-labels uidat)
(let* ((rown 0)
(lftcol (vector-ref uidat 0))
(numcols (vector-length lftcol))
(maxn (- numcols 1))
(allvals (make-vector numcols "")))
(for-each (lambda (name)
|
| ︙ | | |
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
|
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(take-right *allruns* numruns)
(pad-list *allruns* numruns)))
(lftcol (vector-ref uidat 0))
(tableheader (vector-ref uidat 1))
(table (vector-ref uidat 2))
(coln 0))
(update-labels uidat)
(for-each
(lambda (popup)
(let* ((test-id (car popup))
(widgets (hash-table-ref *examine-test-dat* popup))
(stepslbl (hash-table-ref/default widgets "Test Steps" #f)))
(if stepslbl
(let* ((fmtstr "~15a~8a~8a~20a")
(newtxt (string-intersperse
(append
(list
(format #f fmtstr "Stepname" "State" "Status" "Event Time")
(format #f fmtstr "========" "=====" "======" "=========="))
(map (lambda (x)
;; take advantage of the \n on time->string
(format #f fmtstr
(db:step-get-stepname x)
(db:step-get-state x)
(db:step-get-status x)
(time->string
(seconds->local-time
(db:step-get-event_time x)))))
(db-get-test-steps-for-run *db* test-id)))
"\n")))
(iup:attribute-set! stepslbl "TITLE" newtxt)))))
(hash-table-keys *examine-test-dat*))
|
| ︙ | | |
338
339
340
341
342
343
344
345
346
347
348
349
350
351
|
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
|
+
+
|
(res '()))
(cond
((>= testnum ntests)
;; now lftlst will be an hbox with the test keys and the test name labels
(set! lftlst (append lftlst (list (apply iup:vbox (reverse res))))))
(else
(let ((labl (iup:button "" #:flat "YES" #:size "100x15" #:fontsize "10")))
(iup:attribute-set! labl "ACTION" (lambda (obj)
(toggle-hide (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 '()))
|
| ︙ | | |