Megatest

Diff
Login

Differences From Artifact [377ac3812f]:

To Artifact [78e2859a5d]:


1
2
3
4
5
6
7
8
9
10
11

12
13
14
15
16
17
18
;;======================================================================
;; Copyright 2006-2011, 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.
;;======================================================================


(require-library iup)
(import (prefix iup iup:))

;; (use canvas-draw)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)












>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
;;======================================================================
;; Copyright 2006-2011, 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)
(require-library iup)
(import (prefix iup iup:))

;; (use canvas-draw)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)

47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
(define *alltestnames* (make-hash-table)) ;; build a minimalized list of test names
(define *alltestnamelst* '())
(define *searchpatts*  (make-hash-table))
(define *num-runs*      10)
(define *num-tests*     15)
(define *start-run-offset*  0)
(define *start-test-offset* 0)


(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))








|







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
(define *alltestnames* (make-hash-table)) ;; build a minimalized list of test names
(define *alltestnamelst* '())
(define *searchpatts*  (make-hash-table))
(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 (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))

87
88
89
90
91
92
93

94
95
96


97
98
99
100
101
102
103
	       (origtest     (vector-ref buttondat 3))
	       (run-key      (vector-ref buttondat 4))
	       (test         (db:get-test-info *db*
					       run-id
					       (db:test-get-testname  origtest)
					       (db:test-get-item-path origtest)))
	       (rundir       (db:test-get-rundir test))

	       (testname     (db:test-get-testname   test))
	       (itempath     (db:test-get-item-path test))
	       (testfullname (runs:test-get-full-path test))


	       (currstatus   (db:test-get-status test))
	       (currstate    (db:test-get-state  test))
	       (currcomment  (db:test-get-comment test))
	       (host         (db:test-get-host test))
	       (cpuload      (db:test-get-cpuload test))
	       (runtime      (db:test-get-run_duration test))
	       (logfile      (conc (db:test-get-rundir test) "/" (db:test-get-final_logf test)))







>



>
>







88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
	       (origtest     (vector-ref buttondat 3))
	       (run-key      (vector-ref buttondat 4))
	       (test         (db:get-test-info *db*
					       run-id
					       (db:test-get-testname  origtest)
					       (db:test-get-item-path origtest)))
	       (rundir       (db:test-get-rundir test))
	       (test-id      (db:test-get-id     test))
	       (testname     (db:test-get-testname   test))
	       (itempath     (db:test-get-item-path test))
	       (testfullname (runs:test-get-full-path test))
	       (testkey      (list test-id testname itempath testfullname))
	       (widgets      (make-hash-table)) ;; put the widgets to update in this hashtable
	       (currstatus   (db:test-get-status test))
	       (currstate    (db:test-get-state  test))
	       (currcomment  (db:test-get-comment test))
	       (host         (db:test-get-host test))
	       (cpuload      (db:test-get-cpuload test))
	       (runtime      (db:test-get-run_duration test))
	       (logfile      (conc (db:test-get-rundir test) "/" (db:test-get-final_logf test)))
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
						    "")))
				     (system (conc "cd " rundir 
						   ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
				   (message-window  (conc "Directory " rundir " not found")))))
	       (newstatus    currstatus)
	       (newstate     currstate)
	       (self         #f))


	  
	  ;;  (test-set-status! db run-id test-name state status itemdat)
	  (set! self 
		(iup:dialog
		 #:title testfullname

		 (iup:vbox
		  (iup:hbox 
		   (iup:frame (iup:label run-key))
		   (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:expand "YES")))
		  (iup:frame #:title "Actions" #:expand "YES"
			     (iup:hbox ;; the actions box
			      (iup:button "View Log"    #:action viewlog  #:expand "YES")
			      (iup:button "Start Xterm" #:action xterm  #:expand "YES")))
		  (iup:frame #:title "Set fields"
			     (iup:vbox
			      (iup:hbox 
			       (iup:vbox ;; the state
				(iup:label "STATE:" #:size "30x")
				(let ((lb (iup:listbox #:action (lambda (val a b c)
								  ;; (print val " a: " a " b: " b " c: " c)
								  (set! newstate a))
						       #:editbox "YES"
						       #:expand "YES")))
				  (iuplistbox-fill-list lb
							(list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ" "CHECK")
							currstate)
				  lb))
			       (iup:vbox ;; the status
				(iup:label "STATUS:" #:size "30x")
				(let ((lb (iup:listbox #:action (lambda (val a b c)
								  (set! newstatus a))
						       #:editbox "YES"
						       #:value currstatus
						       #:expand "YES")))
				  (iuplistbox-fill-list lb
							(list "PASS" "WARN" "FAIL" "CHECK" "n/a")
							currstatus)
				  lb)))
			      (iup:hbox (iup:label "Comment:")
					(iup:textbox #:action (lambda (val a b)
								(set! currcomment b))
						     #:value currcomment 
						     #:expand "YES"))
			      (iup:button "Apply"
					  #:expand "YES"
					  #:action (lambda (x)
						     (test-set-status! *db* run-id testname newstate newstatus itempath currcomment)))
			      (iup:hbox (iup:button "Apply and close"
						    #:expand "YES"
						    #:action (lambda (x)

							       (test-set-status! *db* run-id testname newstate newstatus itempath currcomment)
							       (iup:destroy! self)))
					(iup:button "Cancel and close"
						    #:expand "YES"
						    #:action (lambda (x)

							       (iup:destroy! self))))





			      )))))
	  (iup:show self)
	  ))))

(define (colors-similar? color1 color2)
  (let* ((c1 (map string->number (string-split color1)))
	 (c2 (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (update-rundat patt numruns)
  (let* ((allruns     (db-get-runs *db* patt numruns *start-run-offset*))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0))
    (for-each (lambda (run)
		(let* ((run-id   (db-get-value-by-header run header "id"))
		       (tests    (db-get-tests-for-run *db* run-id))
		       (key-vals (get-key-vals *db* run-id)))
		  (if (> (length tests) maxtests)
		      (set! maxtests (length tests)))
		  (set! result (cons (vector run tests key-vals) result))))
	      runs)
    (set! *header*  header)
    (set! *allruns* (reverse result))
    maxtests))

(define (update-labels uidat)
  (let* ((rown    0)
	 (lftcol (vector-ref uidat 0))
	 (maxn   (- (vector-length lftcol) 1)))
    (let loop ((i 0))
      (iup:attribute-set! (vector-ref lftcol i) "TITLE" "")
      (if (<= i rown)
	  (loop (+ i 1))))
    (for-each (lambda (name)
		(if (<= rown maxn)
		    (let ((labl (vector-ref lftcol rown)))
		      (iup:attribute-set! labl "TITLE" name)))
		(set! rown (+ 1 rown)))
	      (drop *alltestnamelst* *start-test-offset*))))

(define (update-buttons uidat numruns numtests)
  (let* ((runs        (if (> (length *allruns*) numruns)
			  (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 (rundat)
       (if (not rundat) ;; handle padded runs
	   ;;                ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration
	   (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3)))
       (let* ((run      (vector-ref rundat 0))
	      (testsdat (vector-ref rundat 1))
	      (key-val-dat (vector-ref rundat 2))
	      (run-id   (db-get-value-by-header run *header* "id"))
	      (testnames (delete-duplicates (append *alltestnamelst* 
						    (map test:test-get-fullname testsdat)))) ;; (take (pad-list testsdat numtests) numtests))
	      (key-vals (append key-val-dat
				(list (let ((x (db-get-value-by-header run *header* "runname")))
					(if x x "")))))
	      (run-key  (string-intersperse key-vals "\n")))
	 ;; (run-ht  (hash-table-ref/default alldat run-key #f)))
	 ;; fill in the run header key values

	 (let ((rown      0)
	       (headercol (vector-ref tableheader coln)))
	   (for-each (lambda (kval)
		       (let* ((labl      (vector-ref headercol rown)))
			 (if (not (equal? kval (iup:attribute labl "TITLE")))
			     (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
			 (set! rown (+ rown 1))))







>
>





>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
>
|
>
>
>
>
>
|









|
|






|















|

















|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|













>







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
286
287
288
289
290
291
						    "")))
				     (system (conc "cd " rundir 
						   ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
				   (message-window  (conc "Directory " rundir " not found")))))
	       (newstatus    currstatus)
	       (newstate     currstate)
	       (self         #f))

	  (hash-table-set! *examine-test-dat* testkey widgets)
	  
	  ;;  (test-set-status! db run-id test-name state status itemdat)
	  (set! self 
		(iup:dialog
		 #:title testfullname
		 (iup:hbox ;; Need a full height box for all the test steps
		  (iup:vbox
		   (iup:hbox 
		    (iup:frame (iup:label run-key))
		    (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:expand "YES")))
		   (iup:frame #:title "Actions" #:expand "YES"
			      (iup:hbox ;; the actions box
			       (iup:button "View Log"    #:action viewlog  #:expand "YES")
			       (iup:button "Start Xterm" #:action xterm  #:expand "YES")))
		   (iup:frame #:title "Set fields"
			      (iup:vbox
			       (iup:hbox 
				(iup:vbox ;; the state
				 (iup:label "STATE:" #:size "30x")
				 (let ((lb (iup:listbox #:action (lambda (val a b c)
								   ;; (print val " a: " a " b: " b " c: " c)
								   (set! newstate a))
							#:editbox "YES"
							#:expand "YES")))
				   (iuplistbox-fill-list lb
							 (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ" "CHECK")
							 currstate)
				   lb))
				(iup:vbox ;; the status
				 (iup:label "STATUS:" #:size "30x")
				 (let ((lb (iup:listbox #:action (lambda (val a b c)
								   (set! newstatus a))
							#:editbox "YES"
							#:value currstatus
							#:expand "YES")))
				   (iuplistbox-fill-list lb
							 (list "PASS" "WARN" "FAIL" "CHECK" "n/a")
							 currstatus)
				   lb)))
			       (iup:hbox (iup:label "Comment:")
					 (iup:textbox #:action (lambda (val a b)
								 (set! currcomment b))
						      #:value currcomment 
						      #:expand "YES"))
			       (iup:button "Apply"
					   #:expand "YES"
					   #:action (lambda (x)
						      (test-set-status! *db* run-id testname newstate newstatus itempath currcomment)))
			       (iup:hbox (iup:button "Apply and close"
						     #:expand "YES"
						     #:action (lambda (x)
								(hash-table-delete! *examine-test-dat* testkey)
								(test-set-status! *db* run-id testname newstate newstatus itempath currcomment)
								(iup:destroy! self)))
					 (iup:button "Cancel and close"
						     #:expand "YES"
						     #:action (lambda (x)
								(hash-table-delete! *examine-test-dat* testkey)
								(iup:destroy! self))))
			       )))
		  (iup:hbox ;; the test steps are tracked here
		   (let ((stepsdat (iup:label "Test steps ......................................" #:expand "YES")))
		     (hash-table-set! widgets "Test Steps" stepsdat)
		     stepsdat)
		   ))))
	  (iup:show self)
	  ))))

(define (colors-similar? color1 color2)
  (let* ((c1 (map string->number (string-split color1)))
	 (c2 (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (update-rundat runnamepatt numruns testnamepatt itemnamepatt)
  (let* ((allruns     (db-get-runs *db* runnamepatt numruns *start-run-offset*))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0))
    (for-each (lambda (run)
		(let* ((run-id   (db-get-value-by-header run header "id"))
		       (tests    (db-get-tests-for-run *db* run-id testnamepatt itemnamepatt))
		       (key-vals (get-key-vals *db* run-id)))
		  (if (> (length tests) maxtests)
		      (set! maxtests (length tests)))
		  (set! result (cons (vector run tests key-vals) result))))
	      runs)
    (set! *header*  header)
    (set! *allruns* (reverse result))
    maxtests))

(define (update-labels uidat)
  (let* ((rown    0)
	 (lftcol (vector-ref uidat 0))
	 (maxn   (- (vector-length lftcol) 1)))
    (let loop ((i 0))
      (iup:attribute-set! (vector-ref lftcol i) "TITLE" "")
      (if (< i maxn)
	  (loop (+ i 1))))
    (for-each (lambda (name)
		(if (<= rown maxn)
		    (let ((labl (vector-ref lftcol rown)))
		      (iup:attribute-set! labl "TITLE" name)))
		(set! rown (+ 1 rown)))
	      (drop *alltestnamelst* *start-test-offset*))))

(define (update-buttons uidat numruns numtests)
  (let* ((runs        (if (> (length *allruns*) numruns)
			  (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~17a")
		    (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*))
    (set! *alltestnamelst* '())
    (for-each
     (lambda (rundat)
       (if (not rundat) ;; handle padded runs
	   ;;           ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration
	   (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3)))
       (let* ((run      (vector-ref rundat 0))
	      (testsdat (vector-ref rundat 1))
	      (key-val-dat (vector-ref rundat 2))
	      (run-id   (db-get-value-by-header run *header* "id"))
	      (testnames (delete-duplicates (append *alltestnamelst* 
						    (map test:test-get-fullname testsdat)))) ;; (take (pad-list testsdat numtests) numtests))
	      (key-vals (append key-val-dat
				(list (let ((x (db-get-value-by-header run *header* "runname")))
					(if x x "")))))
	      (run-key  (string-intersperse key-vals "\n")))
	 ;; (run-ht  (hash-table-ref/default alldat run-key #f)))
	 ;; fill in the run header key values
	 (set! *alltestnamelst* testnames)
	 (let ((rown      0)
	       (headercol (vector-ref tableheader coln)))
	   (for-each (lambda (kval)
		       (let* ((labl      (vector-ref headercol rown)))
			 (if (not (equal? kval (iup:attribute labl "TITLE")))
			     (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
			 (set! rown (+ rown 1))))
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
		      (vector-set! buttondat 4 run-key)
		      (if (not (hash-table-ref/default *alltestnames* testfullname #f))
			  (begin
			    (hash-table-set! *alltestnames* testfullname #t)
			    (set! *alltestnamelst* (append *alltestnamelst* (list testfullname))))))
		    )
		(set! rown (+ rown 1))))

	    (drop testnames *start-test-offset*)))


	 (set! coln (+ coln 1))))
     runs)))

(define (mkstr . x)
  (string-intersperse (map conc x) ","))

(define (update-search x val)
  (print "Setting search for " x " to " val)
  (hash-table-set! *searchpatts* x val))

(define (make-dashboard-buttons nruns ntests keynames)
  (let* ((nkeys   (length keynames))
	 (runsvec (make-vector nruns))
	 (header  (make-vector nruns))
	 (lftcol  (make-vector ntests))
	 (controls '())
	 (lftlst  '())
	 (hdrlst  '())
	 (bdylst  '())
	 (result  '())
	 (i       0))
    ;; controls (along bottom)
    (set! controls
	  (iup:hbox






	   (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit)))
	   (iup:button "<-  Left" #:action (lambda (obj)(set! *start-run-offset*  (+ *start-run-offset* 1))))
	   (iup:button "Up     ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0))))
	   (iup:button "Down   v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1)))))
	   (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset*  (if (> *start-run-offset* 0)(- *start-run-offset* 1) 0))))))
    
    ;; create the left most column for the run key names and the test names 







>
|
>
>







|
















>
>
>
>
>
>







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
		      (vector-set! buttondat 4 run-key)
		      (if (not (hash-table-ref/default *alltestnames* testfullname #f))
			  (begin
			    (hash-table-set! *alltestnames* testfullname #t)
			    (set! *alltestnamelst* (append *alltestnamelst* (list testfullname))))))
		    )
		(set! rown (+ rown 1))))
	    (let ((xl (if (> (length testnames) *start-test-offset*)
			  (drop testnames *start-test-offset*)
			  testnames)))
	      (append xl (make-list (- *num-tests* (length xl)) "")))))
	 (set! coln (+ coln 1))))
     runs)))

(define (mkstr . x)
  (string-intersperse (map conc x) ","))

(define (update-search x val)
  ;; (print "Setting search for " x " to " val)
  (hash-table-set! *searchpatts* x val))

(define (make-dashboard-buttons nruns ntests keynames)
  (let* ((nkeys   (length keynames))
	 (runsvec (make-vector nruns))
	 (header  (make-vector nruns))
	 (lftcol  (make-vector ntests))
	 (controls '())
	 (lftlst  '())
	 (hdrlst  '())
	 (bdylst  '())
	 (result  '())
	 (i       0))
    ;; controls (along bottom)
    (set! controls
	  (iup:hbox
	   (iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
			#:action (lambda (obj unk val)
				   (update-search "test-name" val)))
	   (iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
			#:action (lambda (obj unk val)
				   (update-search "item-name" val)))
	   (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit)))
	   (iup:button "<-  Left" #:action (lambda (obj)(set! *start-run-offset*  (+ *start-run-offset* 1))))
	   (iup:button "Up     ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0))))
	   (iup:button "Down   v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1)))))
	   (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset*  (if (> *start-run-offset* 0)(- *start-run-offset* 1) 0))))))
    
    ;; create the left most column for the run key names and the test names 
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
		      (iup:vbox
		       ;; the header
		       (apply iup:hbox (reverse hdrlst))
		       (apply iup:hbox (reverse bdylst))))))
       controls)))
    (vector lftcol header runsvec)))

(set! *num-tests* (max (update-rundat "%" *num-runs*) 8))

(set! uidat (make-dashboard-buttons *num-runs* *num-tests* dbkeys))
;; (megatest-dashboard)

(define (run-update other-thread)
  (let loop ((i 0))
    (thread-sleep! 0.1)
    (thread-suspend! other-thread)
    (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs*)
    (update-buttons uidat *num-runs* *num-tests*)



    (thread-resume! other-thread)
    (loop (+ i 1))))

(define th2 (make-thread iup:main-loop))
(define th1 (make-thread (run-update th2)))
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)







|








<

>
>
>








458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473

474
475
476
477
478
479
480
481
482
483
484
485
		      (iup:vbox
		       ;; the header
		       (apply iup:hbox (reverse hdrlst))
		       (apply iup:hbox (reverse bdylst))))))
       controls)))
    (vector lftcol header runsvec)))

(set! *num-tests* (min (max (update-rundat "%" *num-runs* "%" "%") 8) 20))

(set! uidat (make-dashboard-buttons *num-runs* *num-tests* dbkeys))
;; (megatest-dashboard)

(define (run-update other-thread)
  (let loop ((i 0))
    (thread-sleep! 0.1)
    (thread-suspend! other-thread)

    (update-buttons uidat *num-runs* *num-tests*)
    (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs*
		   (hash-table-ref/default *searchpatts* "test-name" "%")
		   (hash-table-ref/default *searchpatts* "item-name" "%"))
    (thread-resume! other-thread)
    (loop (+ i 1))))

(define th2 (make-thread iup:main-loop))
(define th1 (make-thread (run-update th2)))
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)