Megatest

Diff
Login

Differences From Artifact [a4ddccb773]:

To Artifact [981b21b733]:


22
23
24
25
26
27
28

29


30
31
32
33
34
35
36
37


38
39
40
41
42
43
44
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







+

+
+








+
+







(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

;;======================================================================
;; C O M M O N
;;======================================================================

(define *dashboard-comment-share-slot* #f)

(define (dtests:get-pre-command #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
    (or cfg-ovrd default-override "xterm -geometry 180x20 -e \"")))

(define (dtests:get-post-command #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
88
89
90
91
92
93
94
95

96
97
98
99
100
101
102
93
94
95
96
97
98
99

100
101
102
103
104
105
106
107







-
+







			 (iup:label "TestComment                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (let ((newcomment (db:test-get-comment testdat)))
			     (if *dashboard-comment-share-slot*
				 (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE")
						  newcomment))
				     (iup:attribute-set! *dashboard-comment-slot*
				     (iup:attribute-set! *dashboard-comment-share-slot*
							 "VALUE"
							 newcomment)))
			     newcomment)))
	    (store-label "testid"
			 (iup:label "TestId                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
123
124
125
126
127
128
129
130

131
132
133
134
135
136
137
138
128
129
130
131
132
133
134

135

136
137
138
139
140
141
142







-
+
-







	   (append (map (lambda (val)
			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Author: "
			      "Owner: "
			      "Reviewed: "
			      "Tags: "
			      "Description: "
			      "Description: "))
			      ))
		   (list (iup:label "" #:expand "VERTICAL"))))
    (apply iup:vbox  ; #:expand "YES"
	   (list 
	    (store-meta "author"
			 (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL")
			 (lambda (testmeta)(db:testmeta-get-author testmeta)))
	    (store-meta "owner"
150
151
152
153
154
155
156
157

158
159

160
161

162
163
164
165
166
167
168
154
155
156
157
158
159
160

161
162

163
164

165
166
167
168
169
170
171
172







-
+

-
+

-
+







			   (test-meta-panel-get-description testmeta)))
	    )))))


;;======================================================================
;; Run info panel
;;======================================================================
(define (run-info-panel keydat testdat runname)
(define (run-info-panel db keydat testdat runname)
  (let* ((run-id     (db:test-get-run_id testdat))
	 (rundat     (cdb:remote-run db:get-run-info #f run-id))
	 (rundat     (db:get-run-info db run-id))
	 (header     (db:get-header rundat))
	 (event_time (db:get-value-by-header (db:get-row rundat)
	 (event_time (db:get-value-by-header (db:get-rows rundat)
					     (db:get-header rundat)
					     "event_time")))
    (iup:frame 
     #:title "Megatest Run Info" ; #:expand "YES"
     (iup:hbox ; #:expand "YES"
      (apply iup:vbox ; #:expand "YES"
	     (append (map (lambda (keyval)
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
292
293
294
295
296

297
298
299

300
301
302
303
304
305
306
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
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







-
+
+





+
-
+
+



+
-
+









-
+

-
+
+
+
+
+

















-
+









+

-
+












-
+


-
+


















-
+










-
+


-
+







			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Hostname: "
			      "Uname -a: "
			      "Disk free: "
			      "CPU Load: "
			      "Run duration: "
			      "Logfile: "))
			      "Logfile: "
			      "Top process id: "))
		   (iup:label "" #:expand "VERTICAL")))
    (apply iup:vbox ; #:expand "YES"
	   (list
	    ;; NOTE: Yes, the host can change!
	    (store-label "HostName"
			 (iup:label ;; (sdb:qry 'getstr 
			 (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL")
			  (db:test-get-host testdat) ;; )
			  #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-host testdat)))
	    (store-label "Uname"
			 (iup:label "                                                   " #:expand "HORIZONTAL")
			 (lambda (testdat) ;; (sdb:qry 'getstr 
			 (lambda (testdat)(db:test-get-uname testdat)))
			   (db:test-get-uname testdat))) ;; )
	    (store-label "DiskFree"
			 (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-diskfree testdat))))
	    (store-label "CPULoad"
			 (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-cpuload testdat))))
	    (store-label "RunDuration"
			 (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat)))))
	    (store-label "CPULoad"
	    (store-label "LogFile"
			 (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-final_logf testdat)))))))))
			 (lambda (testdat)(conc (db:test-get-final_logf testdat))))
	    (store-label "ProcessId"
			 (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-process_id testdat))))
	    )))))

;; use a global for setting the buttons colors
;;                           state status teststeps
(define *state-status* (vector #f #f #f))
(define (update-state-status-buttons testdat)
  (let* ((state  (db:test-get-state  testdat))
	 (status (db:test-get-status testdat))
	 (color  (car (gutils:get-color-for-state-status state status))))
    ((vector-ref *state-status* 0) state color)
    ((vector-ref *state-status* 1) status color)))

(define *dashboard-test-db* #t)
(define *dashboard-comment-share-slot* #f)

;;======================================================================
;; Set fields 
;;======================================================================
(define (set-fields-panel test-id testdat #!key (db #f))
(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f))
  (let ((newcomment #f)
	(newstatus  #f)
	(newstate   #f)
	(wtxtbox    #f))
    (iup:frame
     #:title "Set fields"
     (iup:vbox
      (iup:hbox (iup:label "Comment:")
		(let ((txtbox (iup:textbox #:action (lambda (val a b)
						      (rmt:test-set-state-status-by-id run-id test-id #f #f b)
						      ;; IDEA: Just set a variable with the proc to call?
						      (open-run-close db:test-set-state-status-by-id db test-id #f #f b)
						      (rmt:test-set-state-status-by-id run-id test-id #f #f b)
						      (set! newcomment b))
					   #:value (db:test-get-comment testdat)
					   #:expand "HORIZONTAL")))
		  (set! wtxtbox txtbox)
		  txtbox))
		  
      (apply iup:hbox
	     (iup:label "STATE:" #:size "30x")
	     (let* ((btns  (map (lambda (state)
				  (let ((btn (iup:button state
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (open-run-close db:test-set-state-status-by-id db test-id state #f #f)
								    (rmt:test-set-state-status-by-id run-id test-id state #f #f)
								    (db:test-set-state! testdat state)))))
				    btn))
				*common:std-states*))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
				(map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
	       (vector-set! *state-status* 0
			    (lambda (state color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name state) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
				       (iup:attribute-set! btn "BGCOLOR" newcolor))))
			       btns)))
	       btns))
      (apply iup:hbox
	     (iup:label "STATUS:" #:size "30x")
	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (let ((t (iup:attribute x "TITLE")))
								      (if (equal? t "WAIVED")
									  (iup:show (dashboard-tests:waiver testdat 
									  (iup:show (dashboard-tests:waiver run-id testdat 
													    (if wtxtbox (iup:attribute wtxtbox "VALUE") #f)
													    (lambda (c)
													      (set! newcomment c)
													      (if wtxtbox 
														  (begin
														    (iup:attribute-set! wtxtbox "VALUE" c)
														    (if (not *dashboard-comment-share-slot*)
															(set! *dashboard-comment-share-slot* wtxtbox)))
														  ))))
									  (begin
									    (open-run-close db:test-set-state-status-by-id db test-id #f status #f)
									    (rmt:test-set-state-status-by-id run-id test-id #f status #f)
									    (db:test-set-status! testdat status))))))))
				    btn))
				*common:std-statuses*))) ;; (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
				(map cadr *common:std-statuses*)))) ;; (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name status) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
338
339
340
341
342
343
344
345

346
347
348
349
350
351
352
351
352
353
354
355
356
357

358
359
360
361
362
363
364
365







-
+







					 (conc "ezstep run from step " stepname)))))
    ;; (iup:button "Refresh test data"
    ;;     	#:expand "HORIZONTAL"
    ;;     	#:action (lambda (obj)
    ;;     		   (print "Refresh test data " stepname))
    )))

(define (dashboard-tests:waiver testdat ovrdval cmtcmd)
(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd)
  (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt"))
	 (wregx (if (string? wpatt)(regexp wpatt) #f))
	 (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) "")))
	 (comnt (iup:textbox #:action (lambda (val a b)
					(if wpatt
					    (if (string-match wregx b)
						(iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt))
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
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







-
+








+




-
-
-
-
+
+
+
+
+







-
-
-
-
+
+
+
+


+






-
-
+
+



-
+







			      #:expand "HORIZONTAL"
			      #:action (lambda (obj)
					 (let ((comment (iup:attribute comnt "VALUE"))
					       (test-id (db:test-get-id testdat)))
					   (if (or (not wpatt)
						   (string-match wregx comment))
					       (begin
						 (open-run-close db:test-set-state-status-by-id #f test-id #f "WAIVED" comment)
						 (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
						 (db:test-set-status! testdat "WAIVED")
						 (cmtcmd comment)
						 (iup:destroy! dlog))))))
		  (iup:button "Cancel"
			      #:expand "HORIZONTAL" 
			      #:action (lambda (obj)
					 (iup:destroy! dlog)))))))
    dlog))


;;======================================================================
;;
;;======================================================================
(define (examine-test test-id) ;; run-id run-key origtest)
  (let* ((db-path       (conc *toppath* "/megatest.db"))
	 (db            (open-db))
	 (testdat       (open-run-close db:get-test-info-by-id db test-id))
(define (examine-test run-id test-id) ;; run-id run-key origtest)
  (let* ((db-path       (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
	 (dbstruct      (make-dbr:dbstruct path:  (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") 
					   local: #t))
	 (testdat       (db:get-test-info-by-id dbstruct run-id test-id))
	 (db-mod-time   0) ;; (file-modification-time db-path))
	 (last-update   0) ;; (current-seconds))
	 (request-update #t))
    (if (not testdat)
	(begin
	  (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
	  (exit 1))
	(let* ((run-id        (if testdat (db:test-get-run_id testdat) #f))
	       (keydat        (if testdat (open-run-close db:get-key-val-pairs db run-id) #f))
	       (rundat        (if testdat (open-run-close db:get-run-info db run-id) #f))
	       (runname       (if testdat (db:get-value-by-header (db:get-row rundat)
	(let* (;; (run-id        (if testdat (db:test-get-run_id testdat) #f))
	       (keydat        (if testdat (db:get-key-val-pairs dbstruct run-id) #f))
	       (rundat        (if testdat (db:get-run-info dbstruct run-id) #f))
	       (runname       (if testdat (db:get-value-by-header (db:get-rows rundat)
								  (db:get-header rundat)
								  "runname") #f))
	       ;; (tdb           (tdb:open-test-db-by-test-id-local dbstruct run-id test-id))
	       ;; These next two are intentional bad values to ensure errors if they should not
	       ;; get filled in properly.
	       (logfile       "/this/dir/better/not/exist")
	       (rundir        (if testdat 
				  (db:test-get-rundir testdat)
				  logfile))
	       (testdat-path  (conc rundir "/testdat.db")) ;; this gets recalculated until found 
	       (teststeps     (if testdat (db:get-compressed-steps test-id work-area: rundir) '()))
	       ;; (testdat-path  (conc rundir "/testdat.db")) ;; this gets recalculated until found 
	       (teststeps     (if testdat (tests:get-compressed-steps dbstruct run-id test-id) '()))
	       (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	       (testname      (if testdat (db:test-get-testname testdat) "n/a"))
	       (testmeta      (if testdat 
				  (let ((tm (open-run-close db:testmeta-get-record db testname)))
				  (let ((tm (db:testmeta-get-record dbstruct testname)))
				    (if tm tm (make-db:testmeta)))
				  (make-db:testmeta)))

	       (keystring  (string-intersperse 
			    (map (lambda (keyval)
				   ;; (conc ":" (car keyval) " " (cadr keyval)))
				   (cadr keyval))
444
445
446
447
448
449
450
451
452
453
454
455
456
457







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
486
487
488

489

490

491
492
493
494
495
496
497
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
486

487
488
489

490
491
492
493
494
495
496
497







-
-
-
-
-
-
-
+
+
+
+
+
+
+







-
+
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-



-
+

+
-
+







						  (conc "-e " (get-environment-variable "SHELL"))
						  "")))
				   (system (conc "cd " rundir 
						 ";mt_xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
				 (message-window  (conc "Directory " rundir " not found")))))
	       (widgets    (make-hash-table))
	       (refreshdat (lambda ()
			     (let* ((curr-mod-time (max (file-modification-time db-path)
							(if (file-exists? testdat-path)
							    (file-modification-time testdat-path)
							    (begin
							      (set! testdat-path (conc rundir "/testdat.db"))
							      0))))
				    (need-update   (or (and (> curr-mod-time db-mod-time)
			     (let* ((curr-mod-time (file-modification-time db-path))
				                   ;;     (max ..... (if (file-exists? testdat-path)
						   ;;      	      (file-modification-time testdat-path)
						   ;;      	      (begin
						   ;;      		(set! testdat-path (conc rundir "/testdat.db"))
						   ;;      		0))))
				    (need-update   (or (and (>= curr-mod-time db-mod-time)
							    (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
						       (> (current-milliseconds)(+ last-update 10000))     ;; force update even 10 seconds
						       request-update))
				    (newtestdat (if need-update 
						    ;; NOTE: BUG HIDER, try to eliminate this exception handler
						    (handle-exceptions
						     exn 
						     (debug:print-info 0 "WARNING: test db access issue for test " test-id ": " ((condition-property-accessor 'exn 'message) exn))
						     (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn))
						     (make-db:test)
						     (let* ((newdat (open-run-close db:get-test-info-by-id db test-id ))
						     (db:get-test-info-by-id dbstruct run-id test-id )))))
							    (tstdat (if newdat
									(open-run-close tests:testdat-get-testinfo db test-id #f)
									'())))
						       (if (and newdat 
								(not (null? tstdat))) ;; (update-time cpuload diskfree run-duration)
							   (let* ((rec      (car tstdat))
								  (cpuload  (vector-ref rec 1))
								  (diskfree (vector-ref rec 2))
								  (run-dur  (vector-ref rec 3)))
							     (db:test-set-run_duration! newdat run-dur)
							     (db:test-set-diskfree!     newdat diskfree)
							     (db:test-set-cpuload!      newdat cpuload)))
						       ;; (debug:print 0 "newdat=" newdat)
			       ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time)
						       newdat)
						     )
						    #f)))
			       ;; (debug:print 0 "newtestdat=" newtestdat)
			       (cond
				((and need-update newtestdat)
				 (set! testdat newtestdat)
				 (set! teststeps    (db:get-compressed-steps test-id work-area: rundir))
				 (set! teststeps    (tests:get-compressed-steps dbstruct run-id test-id))
				 (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
				 (set! rundir       ;; (filedb:get-path *fdb* 
				 (set! rundir       (db:test-get-rundir testdat))
				       (db:test-get-rundir testdat)) ;; )
				 (set! testfullname (db:test-get-fullname testdat))
				 ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n    "))
				 
				 ;; I don't see why this was implemented this way. Please comment it ...
				 ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same
				 ;;     (set! db-mod-time (+ curr-mod-time 1))
				 ;;     (set! db-mod-time curr-mod-time))
555
556
557
558
559
560
561
562

563
564
565
566
567
568
569
555
556
557
558
559
560
561

562
563
564
565
566
567
568
569







-
+







			     (conc "megatest -target " keystring " -runname "  runname 
				   " -set-state-status KILLREQ,n/a -testpatt %/% "
				   " -state RUNNING"))))
	       (run-test  (lambda (x)
			    (iup:attribute-set! 
			     command-text-box "VALUE"
			     (conc "megatest -target " keystring " -runname " runname 
				   " -runtests " (conc testname "/" (if (equal? item-path "")
				   " -run -testpatt " (conc testname "/" (if (equal? item-path "")
									"%" 
									item-path))
				   ))))
	       (remove-test (lambda (x)
			      (iup:attribute-set!
			       command-text-box "VALUE"
			       (conc "megatest -remove-runs -target " keystring " -runname " runname
587
588
589
590
591
592
593
594
595









596
597
598
599
600
601
602
603
604
605
606
607

608
609
610
611
612
613
614
615
616
617
618




619
620


621
622
623
624
625

626
627
628
629
630
631
632
587
588
589
590
591
592
593


594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613

614
615
616
617
618
619
620
621




622
623
624
625
626

627
628
629
630
631
632

633
634
635
636
637
638
639
640







-
-
+
+
+
+
+
+
+
+
+











-
+







-
-
-
-
+
+
+
+

-
+
+




-
+







	       (remove-test (lambda (x)
			      (iup:attribute-set!
			       command-text-box "VALUE"
			       (conc "megatest -remove-runs -target " keystring " -runname " runname
				     " -testpatt " (conc testname "/" (if (equal? item-path "")
									  "%"
									  item-path))
				     " -v"))
			      )))
				     " -v"))))
	       (archive-test  (lambda (x)
				(iup:attribute-set! 
				 command-text-box "VALUE"
				 (conc "megatest -target " keystring " -runname " runname 
				       " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "")
												 "%" 
												 item-path))
				       )))))
	  (cond
	   ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
	   ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
	   (else
	    ;;  (test-set-status! db run-id test-name state status itemdat)
	    (set! self ; 
		  (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
			      #:title testfullname
			      (iup:vbox ; #:expand "YES"
			       ;; The run and test info
			       (iup:hbox  ; #:expand "YES"
				(run-info-panel keydat testdat runname)
				(run-info-panel dbstruct keydat testdat runname)
				(test-info-panel testdat store-label widgets)
				(test-meta-panel testmeta store-meta))
			       (host-info-panel testdat store-label)
			       ;; The controls
			       (iup:frame #:title "Actions" 
					  (iup:vbox
					   (iup:hbox 
					    (iup:button "View Log"      #:action viewlog     #:size "80x")
					    (iup:button "Start Xterm"   #:action xterm       #:size "80x")
					    (iup:button "Run Test"      #:action run-test    #:size "80x")
					    (iup:button "Clean Test"    #:action remove-test #:size "80x")
					    (iup:button "View Log"      #:action viewlog      #:size "80x")
					    (iup:button "Start Xterm"   #:action xterm        #:size "80x")
					    (iup:button "Run Test"      #:action run-test     #:size "80x")
					    (iup:button "Clean Test"    #:action remove-test  #:size "80x")
					    (iup:button "CleanRunExecute!"    #:action clean-run-execute #:size "80x")
					    (iup:button "Kill All Jobs" #:action kill-jobs   #:size "80x")
					    (iup:button "Kill All Jobs" #:action kill-jobs    #:size "80x")
					    (iup:button "Archive Test"  #:action archive-test #:size "80x")
					    (iup:button "Close"         #:action (lambda (x)(exit)) #:size "80x"))
					   (apply 
					    iup:hbox
					    (list command-text-box command-launch-button))))
			       (set-fields-panel test-id testdat)
			       (set-fields-panel dbstruct run-id test-id testdat)
			       (let ((tabs 
				      (iup:tabs
				       ;; Replace here with matrix
				       (let ((steps-matrix (iup:matrix
							    #:font   "Courier New, -8"
							    #:expand "YES"
							    #:scrollbar "YES"
658
659
660
661
662
663
664
665
666
667
668

669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
666
667
668
669
670
671
672




673































674
675
676
677
678
679
680







-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-







					 (iup:attribute-set! steps-matrix "0:5" "Duration")
					 (iup:attribute-set! steps-matrix "0:6" "Log File")
					 (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
					 ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
					 (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
					 (let ((proc
						(lambda (testdat)
						  (let ((max-row 0))
						  (if (not (null? teststeps))
						      (let loop ((hed    (car teststeps))
								 (tal    (cdr teststeps))
						  (dcommon:populate-steps teststeps steps-matrix))))
								 (rownum 1)
								 (colnum 1))
							  (if (> rownum max-row)(set! max-row rownum))
							(let ((val     (vector-ref hed (- colnum 1)))
							      (mtrx-rc (conc rownum ":" colnum)))
							  (iup:attribute-set! steps-matrix  mtrx-rc (if val (conc val) ""))
							  (if (< colnum 6)
							      (loop hed tal rownum (+ colnum 1))
							      (if (not (null? tal))
								    (loop (car tal)(cdr tal)(+ rownum 1) 1))))))
						    (if (> max-row 0)
							(begin
							  ;; we are going to speculatively clear rows until we find a row that is already cleared
							  (let loop ((rownum  (+ max-row 1))
								     (colnum  0)
								     (deleted #f))
							    ;; (debug:print-info 0 "cleaning " rownum ":" colnum)
							    (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum))
								   (next-col (if (eq? colnum 6) 1 (+ colnum 1)))
								   (mtrx-rc  (conc rownum ":" colnum))
								   (curr-val (iup:attribute steps-matrix mtrx-rc)))
							      ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val)
							      (if (and (string? curr-val)
								       (not (equal? curr-val "")))
								  (begin
								    (iup:attribute-set! steps-matrix mtrx-rc "")
								    (loop next-row next-col #t))
								  (if (eq? colnum 6) ;; not done, didn't get a full blank row
								      (if deleted (loop next-row next-col #f)) ;; exit on this not met
								      (loop next-row next-col deleted)))))
							  (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))))
					   (hash-table-set! widgets "StepsMatrix" proc)
					   (proc testdat))
					 steps-matrix)
				       ;; populate the Test Data panel
				       (iup:frame
					#:title "Test Data"
					(let ((test-data
726
727
728
729
730
731
732
733

734
735
736
737
738
739
740
700
701
702
703
704
705
706

707
708
709
710
711
712
713
714







-
+







											      (db:test-data-get-value    x)
											      (db:test-data-get-expected x)
											      (db:test-data-get-tol      x)
											      (db:test-data-get-status   x)
											      (db:test-data-get-units    x)
											      (db:test-data-get-type     x)
											      (db:test-data-get-comment  x)))
										    (open-run-close db:read-test-data db test-id "%")))
										    (db:read-test-data dbstruct run-id test-id "%")))
									      "\n")))
							       (if (not (equal? currval newval))
								   (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
					  test-data))
				       ;;(dashboard:run-controls)
				       )))
				 (iup:attribute-set! tabs "TABTITLE0" "Steps")