Megatest

Check-in [7ae9c97a29]
Login
Overview
Comment:Almost have per run selection working
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: 7ae9c97a298ddbd56340ab9f53e8c9f8fd97e609
User & Date: mrwellan on 2016-07-25 18:18:45
Other Links: branch diff | manifest | tags
Context
2016-07-25
20:02
Selecting by run and test now working check-in: 7e8984fe98 user: matt tags: v1.61
18:18
Almost have per run selection working check-in: 7ae9c97a29 user: mrwellan tags: v1.61
16:07
Added api files check-in: 3c58e0bd57 user: mrwellan tags: v1.61
Changes

Modified Makefile from [ec6f600960] to [224dd09b40].

170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
clean : 
	rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm

#======================================================================
# Make the records files
#======================================================================

vg_records.scm : records.sh
	./records.sh

#======================================================================
# Deploy section (not complete yet)
#======================================================================

$(DEPLOYHELPERS) : utils/mt_*
	$(INSTALL) $< $@







|
|







170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
clean : 
	rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm

#======================================================================
# Make the records files
#======================================================================

# vg_records.scm : records.sh
#	./records.sh

#======================================================================
# Deploy section (not complete yet)
#======================================================================

$(DEPLOYHELPERS) : utils/mt_*
	$(INSTALL) $< $@

Modified dashboard.scm from [a97c0836a7] to [93364af37a].

188
189
190
191
192
193
194

195
196
197
198


199
200
201
202
203
204
205
  draw-cache     ;; 
  start-row
  run-start-row
  max-row
  running-layout
  originx
  originy


  ;; Controls used to launch runs etc.
  command
  command-tb 


  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
  curr-test-ids    ;; used only in dcommon:run-update which is used in newdashboard







>


|

>
>







188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
  draw-cache     ;; 
  start-row
  run-start-row
  max-row
  running-layout
  originx
  originy
  layout-update-ok

  ;; Controls used to launch runs etc.
  command          ;; for run control this is the command being built up
  command-tb 
  key-listboxes
  key-lbs           
  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
  curr-test-ids    ;; used only in dcommon:run-update which is used in newdashboard
250
251
252
253
254
255
256

257
258
259
260
261
262
263


264
265

266
267
268
269
270
271
272

(define (dboard:tabdat-make-data)
  (let ((dat (make-dboard:tabdat
	      allruns-by-id:        (make-hash-table)
	      allruns:              '() ;; list of run records (vectors)
	      buttondat:            (make-hash-table)
	      curr-test-ids:        (make-hash-table)

	      dbdir:                #f
	      filters-changed:      #f
	      header:               #f 
	      hide-empty-runs:      #f
	      hide-not-hide-button: #f
	      hide-not-hide:        #t
	      item-test-names:      '()


	      last-db-update:       0
	      last-data-update:     0

	      not-done-runs:        '()
	      done-runs:            '()
	      num-tests:            15
	      numruns:              16
	      originx:              #f
	      originy:              #f
	      path-run-ids:         (make-hash-table)







>







>
>


>







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:tabdat-make-data)
  (let ((dat (make-dboard:tabdat
	      allruns-by-id:        (make-hash-table)
	      allruns:              '() ;; list of run records (vectors)
	      buttondat:            (make-hash-table)
	      curr-test-ids:        (make-hash-table)
	      command:              ""
	      dbdir:                #f
	      filters-changed:      #f
	      header:               #f 
	      hide-empty-runs:      #f
	      hide-not-hide-button: #f
	      hide-not-hide:        #t
	      item-test-names:      '()
	      keys:                 #f
	      key-listboxes:        #f
	      last-db-update:       0
	      last-data-update:     0
	      layout-update-ok:     #t
	      not-done-runs:        '()
	      done-runs:            '()
	      num-tests:            15
	      numruns:              16
	      originx:              #f
	      originy:              #f
	      path-run-ids:         (make-hash-table)
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
;; 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

  tests          ;; hash of id => testdat
  tests-by-name  ;; hash of testfullname => testdat
  key-vals
  last-update    ;; last query to db got records from before last-update

  )

(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100))
  (make-dboard:rundat 
   run: run
   tests: (or tests (make-hash-table))
   tests-by-name: (make-hash-table)
   key-vals: key-vals 
   last-update: last-update)) ;; -100 is before time began



(define (dboard:rundat-copy-tests-to-by-name rundat)
  (let ((src-ht (dboard:rundat-tests rundat))
	(trg-ht (dboard:rundat-tests-by-name rundat)))
    (if (and (hash-table? src-ht)(hash-table? trg-ht))
	(for-each
	 (lambda (testdat)







>




>


|





|
>
>







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
;; 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  ;; hash of testfullname => testdat
  key-vals
  last-update    ;; last query to db got records from before last-update
  data-changed
  )

(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100));; -100 is before time began
  (make-dboard:rundat 
   run: run
   tests: (or tests (make-hash-table))
   tests-by-name: (make-hash-table)
   key-vals: key-vals 
   last-update: last-update
   data-changed: #t
   )) 

(define (dboard:rundat-copy-tests-to-by-name rundat)
  (let ((src-ht (dboard:rundat-tests rundat))
	(trg-ht (dboard:rundat-tests-by-name rundat)))
    (if (and (hash-table? src-ht)(hash-table? trg-ht))
	(for-each
	 (lambda (testdat)
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
523
524

525
526
527
528
529
530
531
	 (statuses    (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath))

	 (run-dat    (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))


			(if rec rec (dboard:rundat-make-init run: run key-vals: key-vals))))


	 ;; (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
	 (last-update (dboard:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
	 (tmptests    (rmt:get-tests-for-run run-id testnamepatt states statuses  ;; run-id testpatt states statuses
					     #f #f                                ;; offset limit 
					     (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					     sort-by                              ;; sort-by
					     sort-order                           ;; sort-order
					     #f ;; 'shortlist                           ;; qrytype
					     (if (dboard:tabdat-filters-changed tabdat) 
						 0
						 last-update) ;; last-update
					     *dashboard-mode*)) ;; use dashboard mode
	 (use-new    (dboard:tabdat-hide-not-hide tabdat))
	 (tests-ht   (dboard:rundat-tests run-dat))
	 (start-time (current-seconds)))
    (for-each 
     (lambda (tdat)
       (let ((test-id (db:test-get-id tdat))
	     (state   (db:test-get-state tdat)))

	 (if (equal? state "DELETED")
	     (hash-table-delete! tests-ht test-id)
	     (hash-table-set! tests-ht test-id tdat))))
     tmptests)
    (dboard:rundat-last-update-set! run-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured.
    tests-ht))








>

>
>
|
>
>



















>







508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
	 (statuses    (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath))
	 ;; note: the rundat is normally created in "update-rundat". 
	 (run-dat    (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
			(if rec 
			    rec
			    (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
			      (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
			      rd))))
	 ;; (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
	 (last-update (dboard:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
	 (tmptests    (rmt:get-tests-for-run run-id testnamepatt states statuses  ;; run-id testpatt states statuses
					     #f #f                                ;; offset limit 
					     (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					     sort-by                              ;; sort-by
					     sort-order                           ;; sort-order
					     #f ;; 'shortlist                           ;; qrytype
					     (if (dboard:tabdat-filters-changed tabdat) 
						 0
						 last-update) ;; last-update
					     *dashboard-mode*)) ;; use dashboard mode
	 (use-new    (dboard:tabdat-hide-not-hide tabdat))
	 (tests-ht   (dboard:rundat-tests run-dat))
	 (start-time (current-seconds)))
    (for-each 
     (lambda (tdat)
       (let ((test-id (db:test-get-id tdat))
	     (state   (db:test-get-state tdat)))
	 (dboard:rundat-data-changed-set! run-dat #t)
	 (if (equal? state "DELETED")
	     (hash-table-delete! tests-ht test-id)
	     (hash-table-set! tests-ht test-id tdat))))
     tmptests)
    (dboard:rundat-last-update-set! run-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured.
    tests-ht))

913
914
915
916
917
918
919
920
921

922
923
924
925
926
927
928
929
930





931

932

933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963


964
965
966
967
968
969
970
971
972
973
974
975
976
977
978

979
980
981
982
983
984
985
      (if val
	  val
	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))

	 (db-target-dat (rmt:get-targets))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (all-targets   (append db-targets
				(map (lambda (x)
				       (list->vector
					(take (append (string-split x "/")
						      (make-list (length header) "na"))
					      (length header))))





				     runconf-targs)))

	 (key-listboxes (if key-lbs key-lbs (make-list (length header) #f))))

    (let loop ((key     (car header))
	       (remkeys (cdr header))
	       (refvals '())
	       (indx    0)
	       (lbs     '()))
      (let* ((lb (let ((lb (list-ref key-listboxes indx)))
		   (if lb
		       lb
		       (iup:listbox 
			#:size "45x50" 
			#:fontsize "10"
			#:expand "YES" ;; "VERTICAL"
			;; #:dropdown "YES"
			#:editbox "YES"
			#:action (lambda (obj a b c)
				   (debug:catch-and-dump action-proc "update-target-selector"))
			#:caret_cb (lambda (obj a b c)
				     (debug:catch-and-dump action-proc "update-target-selector"))
			))))
	     ;; loop though all the targets and build the list for this dropdown
	     (selected-value (dashboard:populate-target-dropdown lb refvals all-targets)))
	(if (null? remkeys)
	    ;; return a list of the listbox items and an iup:hbox with the labels and listboxes
	    (let ((listboxes (append lbs (list lb))))
	      (list listboxes
		    (map (lambda (htxt lb)
			   (iup:vbox
			    (iup:label htxt) 
			    lb))
			 header
			 listboxes)))


	    (loop (car remkeys)
		  (cdr remkeys)
		  (append refvals (list selected-value))
		  (+ indx 1)
		  (append lbs (list lb))))))))

;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string 
;; interspersed with commas
;;
(define (dashboard:text-list-toggle-box items proc)
  (let ((alltgls (make-hash-table)))
    (apply iup:vbox
	   (map (lambda (item)
		  (iup:toggle 
		   item

		   #:expand "YES"
		   #:action (lambda (obj tstate)
			       (debug:catch-and-dump 
				(lambda ()
				  (if (eq? tstate 0)
				      (hash-table-delete! alltgls item)
				      (hash-table-set! alltgls item #t))







|

>



<
|
|
|
|
|
>
>
>
>
>
|
>

>









|













|
|
|
|
|
|
|
|
>
>















>







930
931
932
933
934
935
936
937
938
939
940
941
942

943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
      (if val
	  val
	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))
	 (key-lbs       (dboard:tabdat-key-listboxes tabdat))
	 (db-target-dat (rmt:get-targets))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))

	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (list->vector
			   (take (append (string-split x "/")
					 (make-list (length header) "na"))
				 (length header)))))
	 (all-targets   (append (list (munge-target (string-intersperse 
						     (map (lambda (x) "%") header)
						     "/")))
				db-targets
				(map munge-target
				     runconf-targs)
				))
	 (key-listboxes (if key-lbs key-lbs (make-list (length header) #f))))
    (if (not (dboard:tabdat-key-listboxes tabdat))(dboard:tabdat-key-listboxes-set! tabdat key-listboxes))
    (let loop ((key     (car header))
	       (remkeys (cdr header))
	       (refvals '())
	       (indx    0)
	       (lbs     '()))
      (let* ((lb (let ((lb (list-ref key-listboxes indx)))
		   (if lb
		       lb
		       (iup:listbox 
			#:size "x60" 
			#:fontsize "10"
			#:expand "YES" ;; "VERTICAL"
			;; #:dropdown "YES"
			#:editbox "YES"
			#:action (lambda (obj a b c)
				   (debug:catch-and-dump action-proc "update-target-selector"))
			#:caret_cb (lambda (obj a b c)
				     (debug:catch-and-dump action-proc "update-target-selector"))
			))))
	     ;; loop though all the targets and build the list for this dropdown
	     (selected-value (dashboard:populate-target-dropdown lb refvals all-targets)))
	(if (null? remkeys)
	    ;; return a list of the listbox items and an iup:hbox with the labels and listboxes
	    (let* ((listboxes (append lbs (list lb)))
		   (res       (list listboxes
				    (map (lambda (htxt lb)
					   (iup:vbox
					    (iup:label htxt) 
					    lb))
					 header
					 listboxes))))
	      (dboard:tabdat-key-listboxes-set! tabdat res)
	      res)
	    (loop (car remkeys)
		  (cdr remkeys)
		  (append refvals (list selected-value))
		  (+ indx 1)
		  (append lbs (list lb))))))))

;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string 
;; interspersed with commas
;;
(define (dashboard:text-list-toggle-box items proc)
  (let ((alltgls (make-hash-table)))
    (apply iup:vbox
	   (map (lambda (item)
		  (iup:toggle 
		   item
		   #:fontsize 8
		   #:expand "YES"
		   #:action (lambda (obj tstate)
			       (debug:catch-and-dump 
				(lambda ()
				  (if (eq? tstate 0)
				      (hash-table-delete! alltgls item)
				      (hash-table-set! alltgls item #t))
1057
1058
1059
1060
1061
1062
1063













1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;














(define (dashboard:run-controls commondat tabdat #!key (tab-num #f))
  (let* ((targets       (make-hash-table))
	 (test-records  (make-hash-table))
	 (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '()))
	 (test-names    (hash-table-keys all-tests-registry))
	 (sorted-testnames #f)
	 (action        "-run")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 (key-listboxes #f)
	 (update-keyvals (lambda ()
			   (let ((targ (map (lambda (x)
					      (iup:attribute x "VALUE"))
					    (car (dashboard:update-target-selector key-listboxes))))
				 (curr-runname (dboard:tabdat-run-name tabdat)))
			     (dboard:tabdat-target-set! tabdat targ)
			;; (if (dboard:tabdat-updater-for-runs tabdat)
			;; 	 ((dboard:tabdat-updater-for-runs tabdat)))
			     (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
				     (equal? (dboard:tabdat-run-name tabdat) ""))
				 (dboard:tabdat-run-name-set! tabdat curr-runname))
			     (dashboard:update-run-command tabdat))))
	 (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    ;; (hash-table-set! tests-draw-state 'scalef 1)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    







>
>
>
>
>
>
>
>
>
>
>
>
>










|
|
<
<
<
|
<
<
<
<
<
<
<







1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115



1116







1117
1118
1119
1120
1121
1122
1123

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;

(define (dboard:target-updater tabdat) ;;  key-listboxes)
  (let ((targ (map (lambda (x)
		     (iup:attribute x "VALUE"))
		   (car (dashboard:update-target-selector tabdat))))
	(curr-runname (dboard:tabdat-run-name tabdat)))
    (dboard:tabdat-target-set! tabdat targ)
    ;; (if (dboard:tabdat-updater-for-runs tabdat)
    ;; 	 ((dboard:tabdat-updater-for-runs tabdat)))
    (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
	    (equal? (dboard:tabdat-run-name tabdat) ""))
	(dboard:tabdat-run-name-set! tabdat curr-runname))
    (dashboard:update-run-command tabdat)))

(define (dashboard:run-controls commondat tabdat #!key (tab-num #f))
  (let* ((targets       (make-hash-table))
	 (test-records  (make-hash-table))
	 (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '()))
	 (test-names    (hash-table-keys all-tests-registry))
	 (sorted-testnames #f)
	 (action        "-run")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 ;;; (key-listboxes #f)
	 (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"



			   (dboard:target-updater (dboard:tabdat-key-listboxes tabdat))))







	 (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    ;; (hash-table-set! tests-draw-state 'scalef 1)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150



1151
1152
1153
1154
1155

1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177


1178
1179
1180
1181
1182
1183
1184

       ;; Target, testpatt, state and status input boxes
       ;;
       (iup:vbox
	;; Command to run, placed over the top of the canvas
	(dcommon:command-action-selector commondat tabdat tab-num: tab-num)
	(dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
	(dcommon:command-testname-selector commondat tabdat update-keyvals key-listboxes))
       
       (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))
       
 ;;(iup:frame
 ;; #:title "Logs" ;; To be replaced with tabs
 ;; (let ((logs-tb (iup:textbox #:expand "YES"
 ;;				   #:multiline "YES")))
 ;;	 (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
 ;;	 logs-tb))
      )))

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-times commondat tabdat #!key (tab-num #f))
  (let ((drawing               (vg:drawing-new))
	(run-times-tab-updater (lambda ()	
				 (debug:catch-and-dump 
				  (lambda ()
				    (let ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num)))
				      (if tabdat
					  (let ((last-data-update (dboard:tabdat-last-data-update tabdat))
						(now-time         (current-seconds)))
					    (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
					    (if (> (- now-time last-data-update) 5)
						(if (not (dboard:tabdat-running-layout tabdat))
						    (begin
						      (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
						      (dboard:tabdat-last-data-update-set! tabdat now-time)
						      (thread-start! (make-thread
								      (lambda ()
									(dboard:tabdat-running-layout-set! tabdat #t)
									(dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
									(dboard:tabdat-running-layout-set! tabdat #f))
								      "run-times-tab-layout-updater")))
						  ))))))
				  "dashboard:run-times-tab-updater"))))



    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL" ;; "HORIZONTAL"
     #:value 200

     (let* ((tb      (iup:treebox
		      #:value 0
		      #:name "Runs"
		      #:expand "YES"
		      #:addexpanded "NO"
		      #:selection-cb
		      (lambda (obj id state)
			(debug:catch-and-dump
			 (lambda ()
			   (let* ((run-path (tree:node->path obj id))
				  (run-id    (tree-path->run-id tabdat (cdr run-path))))
			     (print "run-path: " run-path)
			     (if (number? run-id)
				 (begin
				   (dboard:tabdat-curr-run-id-set! tabdat run-id)
				   (dboard:tabdat-view-changed-set! tabdat #t))
				 (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))))
			 "treebox"))
			;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
		      )))
       (dboard:tabdat-runs-tree-set! tabdat tb)
       tb)


     (iup:vbox
      (let* ((cnv-obj (iup:canvas 
		       ;; #:size "500x400"
		       #:expand "YES"
		       #:scrollbar "YES"
		       #:posx "0.5"
		       #:posy "0.5"







|


















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




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







1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220

       ;; Target, testpatt, state and status input boxes
       ;;
       (iup:vbox
	;; Command to run, placed over the top of the canvas
	(dcommon:command-action-selector commondat tabdat tab-num: tab-num)
	(dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
	(dcommon:command-testname-selector commondat tabdat update-keyvals)) ;;  key-listboxes))
       
       (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))
       
 ;;(iup:frame
 ;; #:title "Logs" ;; To be replaced with tabs
 ;; (let ((logs-tb (iup:textbox #:expand "YES"
 ;;				   #:multiline "YES")))
 ;;	 (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
 ;;	 logs-tb))
      )))

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-times commondat tabdat #!key (tab-num #f))
  (let* ((drawing               (vg:drawing-new))
	 (run-times-tab-updater (lambda ()	
				  (debug:catch-and-dump 
				   (lambda ()
				     (let ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num)))
				       (if tabdat
					   (let ((last-data-update (dboard:tabdat-last-data-update tabdat))
						 (now-time         (current-seconds)))
					     (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
					     (if (> (- now-time last-data-update) 5)
						 (if (not (dboard:tabdat-running-layout tabdat))
						     (begin
						       (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
						       (dboard:tabdat-last-data-update-set! tabdat now-time)
						       (thread-start! (make-thread
								       (lambda ()
									 (dboard:tabdat-running-layout-set! tabdat #t)
									 (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
									 (dboard:tabdat-running-layout-set! tabdat #f))
								       "run-times-tab-layout-updater")))
						     ))))))
				   "dashboard:run-times-tab-updater")))
	 (key-listboxes #f) ;; 
	 (update-keyvals (lambda ()
			   (dboard:target-updater tabdat))))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL" ;; "HORIZONTAL"
     #:value 150
     (iup:vbox
      (let* ((tb      (iup:treebox
		       #:value 0
		       #:name "Runs"
		       #:expand "YES"
		       #:addexpanded "NO"
		       #:selection-cb
		       (lambda (obj id state)
			 (debug:catch-and-dump
			  (lambda ()
			    (let* ((run-path (tree:node->path obj id))
				   (run-id    (tree-path->run-id tabdat (cdr run-path))))
			      (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)
			      (if (number? run-id)
				  (begin
				    (dboard:tabdat-curr-run-id-set! tabdat run-id)
				    (dboard:tabdat-view-changed-set! tabdat #t))
				  (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))))
			  "treebox"))
		       ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
		       )))
	(dboard:tabdat-runs-tree-set! tabdat tb)
	tb)
      (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
      (dcommon:command-testname-selector commondat tabdat update-keyvals))
     (iup:vbox
      (let* ((cnv-obj (iup:canvas 
		       ;; #:size "500x400"
		       #:expand "YES"
		       #:scrollbar "YES"
		       #:posx "0.5"
		       #:posy "0.5"
2488
2489
2490
2491
2492
2493
2494























2495

2496
2497
2498
2499




2500
2501
2502
2503
2504
2505

2506
2507
2508
2509
2510
2511
2512
2513
		   (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
				  userdata: (conc "run-id: " run-id))
		   (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
		   ;; (set! colnum (+ colnum 1))
		   ))))
	 run-ids))
    (print "Updating rundat")























    (update-rundat tabdat

		   "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
		   100  ;; (dboard:tabdat-numruns tabdat)
		   "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
		   ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")




		   (let ((res '()))
		     (for-each (lambda (key)
				 (if (not (equal? key "runname"))
				     (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
				       (if val (set! res (cons (list key val) res))))))
			       (dboard:tabdat-dbkeys tabdat))

		     res))))

;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
  (let ((cnv (dboard:tabdat-cnv tabdat))
	(dwg (dboard:tabdat-drawing tabdat))
	(mtx (dboard:tabdat-runs-mutex tabdat))







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







2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
		   (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
				  userdata: (conc "run-id: " run-id))
		   (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
		   ;; (set! colnum (+ colnum 1))
		   ))))
	 run-ids))
    (print "Updating rundat")
    (if (dboard:tabdat-keys tabdat) ;; have keys yet?
	(let* ((num-keys (length (dboard:tabdat-keys tabdat)))
	       (targpatt (map (lambda (k v)
				(list k v))
			      (dboard:tabdat-keys tabdat)
			      (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/")
						'("%" "%"))
					    (make-list num-keys "%"))
				    num-keys)
			      ))
	       (runpatt   (if (dboard:tabdat-target tabdat)
			     (last (dboard:tabdat-target tabdat))
			     "%")))
	  (print "targpatt: " targpatt " runpatt: " runpatt)

	  (if (dboard:tabdat-view-changed tabdat)
	      (let ((dwg (dboard:tabdat-drawing tabdat)))
		(dboard:tabdat-layout-update-ok-set! tabdat #f)
		(vg:drawing-libs-set! dwg (make-hash-table))
		(vg:drawing-insts-set! dwg (make-hash-table))
		(vg:drawing-cache-set! dwg '())
		(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
		(dboard:tabdat-max-row-set! tabdat 0)))
	  (update-rundat tabdat
			 runpatt
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 100  ;; (dboard:tabdat-numruns tabdat)
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
			 
			 targpatt
			 
			 ;; old method 
			 ;; (let ((res '()))
			 ;;   (for-each (lambda (key)
			 ;;      	 (if (not (equal? key "runname"))
			 ;;      	     (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
			 ;;      	       (if val (set! res (cons (list key val) res))))))
			 ;;             (dboard:tabdat-dbkeys tabdat))
			 ;;   res)
			 )))))

;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
  (let ((cnv (dboard:tabdat-cnv tabdat))
	(dwg (dboard:tabdat-drawing tabdat))
	(mtx (dboard:tabdat-runs-mutex tabdat))
2535
2536
2537
2538
2539
2540
2541

2542
2543
2544
2545
2546
2547
2548
	     (mtx           (dboard:tabdat-runs-mutex tabdat))
	     (drawing      (dboard:tabdat-drawing tabdat))
	     (runslib      (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
	     (layout-start (current-milliseconds))
	     (allruns      (dboard:tabdat-allruns tabdat))
	     (num-runs     (length allruns))
	     (cnv          (dboard:tabdat-cnv tabdat)))

	(if (canvas? cnv)
	    (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
			  ((originx originy)             (canvas-origin cnv))
			  ((calc-y)                      (lambda (rownum)
							   (- (/ sizey 2)
							      (* rownum row-height))))
			  ((fixed-originx)               (if (dboard:tabdat-originx tabdat)







>







2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
	     (mtx           (dboard:tabdat-runs-mutex tabdat))
	     (drawing      (dboard:tabdat-drawing tabdat))
	     (runslib      (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
	     (layout-start (current-milliseconds))
	     (allruns      (dboard:tabdat-allruns tabdat))
	     (num-runs     (length allruns))
	     (cnv          (dboard:tabdat-cnv tabdat)))
	(dboard:tabdat-layout-update-ok-set! tabdat #t)
	(if (canvas? cnv)
	    (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
			  ((originx originy)             (canvas-origin cnv))
			  ((calc-y)                      (lambda (rownum)
							   (- (/ sizey 2)
							      (* rownum row-height))))
			  ((fixed-originx)               (if (dboard:tabdat-originx tabdat)
2568
2569
2570
2571
2572
2573
2574


2575



2576
2577
2578
2579
2580
2581
2582
					    (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
						    (if x x "")))))
		       (run-key  (string-intersperse key-vals "\n"))
		       (run-full-name (string-intersperse key-vals "/"))
		       (curr-run-start-row  (dboard:tabdat-max-row tabdat)))
		  ;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row)
		  (if (not (vg:lib-get-component runslib run-full-name))


		      (let* ((hierdat   (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat))) ;; hierarchial list of ids



			     (tests-ht  (dboard:rundat-tests rundat))
			     (all-tids  (hash-table-keys   tests-ht)) ;; (apply append hierdat)) ;; was testsdat
			     (testsdat  (hash-table-values tests-ht))
			     (runcomp   (vg:comp-new));; new component for this run
			     (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...)
			     ;; (row-height 4)
			     (run-start  (dboard:min-max < (map db:test-get-event_time testsdat)))







>
>
|
>
>
>







2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
					    (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
						    (if x x "")))))
		       (run-key  (string-intersperse key-vals "\n"))
		       (run-full-name (string-intersperse key-vals "/"))
		       (curr-run-start-row  (dboard:tabdat-max-row tabdat)))
		  ;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row)
		  (if (not (vg:lib-get-component runslib run-full-name))
		      (let* ((hierdat   (if (or (dboard:rundat-data-changed rundat) ;; attempt to not sort when possible.
						(not (dboard:rundat-hierdat rundat)))
					    (let ((hd (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))) ;; hierarchial list of ids
					      (dboard:rundat-hierdat-set! rundat hd)
					      hd)
					    (dboard:run-hierdat rundat)))
			     (tests-ht  (dboard:rundat-tests rundat))
			     (all-tids  (hash-table-keys   tests-ht)) ;; (apply append hierdat)) ;; was testsdat
			     (testsdat  (hash-table-values tests-ht))
			     (runcomp   (vg:comp-new));; new component for this run
			     (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...)
			     ;; (row-height 4)
			     (run-start  (dboard:min-max < (map db:test-get-event_time testsdat)))
2667
2668
2669
2670
2671
2672
2673

2674
2675
2676
2677
2678

2679
2680
2681
2682
2683
2684
2685
2686
					    ;; This is the box around the tests of an iterated test
					    (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
											  text:  (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
											  line-color:  (vg:rgb->number  0 0 255 a: 128)
											  font: "Helvetica -10"))
					    ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
					    (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw

				      (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)))))
			    ;; If it is an iterated test put box around it now.
			    (if (not (null? tests-tal))
				(if #f ;; (> (- (current-seconds) update-start-time) 5)
				    (print "drawing runs taking too long")

				    (testsloop  (car tests-tal)(cdr tests-tal)(+ test-num 1))))))
			;; placeholder box
			(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
			;; (let ((y  (calc-y (dboard:tabdat-max-row tabdat)))) ;;  (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
			;;   (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
			;; instantiate the component
			(let* ((extents   (vg:components-get-extents drawing runcomp))
			       (new-xtnts (apply vg:grow-rect 5 5 extents))







>
|




>
|







2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
					    ;; This is the box around the tests of an iterated test
					    (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
											  text:  (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
											  line-color:  (vg:rgb->number  0 0 255 a: 128)
											  font: "Helvetica -10"))
					    ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
					    (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw
				      (if (dboard:tabdat-layout-update-ok tabdat)
					  (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs))))))
			    ;; If it is an iterated test put box around it now.
			    (if (not (null? tests-tal))
				(if #f ;; (> (- (current-seconds) update-start-time) 5)
				    (print "drawing runs taking too long")
				    (if (dboard:tabdat-layout-update-ok tabdat)
					(testsloop  (car tests-tal)(cdr tests-tal)(+ test-num 1)))))))
			;; placeholder box
			(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
			;; (let ((y  (calc-y (dboard:tabdat-max-row tabdat)))) ;;  (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
			;;   (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
			;; instantiate the component
			(let* ((extents   (vg:components-get-extents drawing runcomp))
			       (new-xtnts (apply vg:grow-rect 5 5 extents))
2699
2700
2701
2702
2703
2704
2705

2706
2707
2708
2709
2710
2711
2712
2713
2714

2715
2716
2717
2718
2719
2720
2721
2722
			  (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 2))
			  ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
			  ))
		      ;; end of the run handling loop 
		      (let ((newdoneruns (cons rundat doneruns)))
			(if (null? runtal)
			    (begin

			      (dboard:tabdat-not-done-runs-set! tabdat '())
			      (dboard:tabdat-done-runs-set! tabdat allruns))
			    (if #f ;; (> (- (current-seconds) update-start-time) 5)
				(begin
				  (print "drawing runs taking too long....  have " (length runtal) " remaining")
				  ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
				  ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
				  (dboard:tabdat-not-done-runs-set! tabdat runtal))
				(begin

				  (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)))))))) ;;  new-run-start-row
	      )
	    (print "Layout end: " (current-milliseconds) " delta: " (- (current-milliseconds) layout-start))))
      (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))

(define (dashboard:runs-tab-updater commondat tab-num)
  (debug:catch-and-dump 
   (lambda ()







>









>
|







2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
			  (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 2))
			  ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
			  ))
		      ;; end of the run handling loop 
		      (let ((newdoneruns (cons rundat doneruns)))
			(if (null? runtal)
			    (begin
			      (dboard:rundat-data-changed-set! rundat #f) 
			      (dboard:tabdat-not-done-runs-set! tabdat '())
			      (dboard:tabdat-done-runs-set! tabdat allruns))
			    (if #f ;; (> (- (current-seconds) update-start-time) 5)
				(begin
				  (print "drawing runs taking too long....  have " (length runtal) " remaining")
				  ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
				  ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
				  (dboard:tabdat-not-done-runs-set! tabdat runtal))
				(begin
				  (if (dboard:tabdat-layout-update-ok tabdat)
				      (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns))))))))) ;;  new-run-start-row
	      )
	    (print "Layout end: " (current-milliseconds) " delta: " (- (current-milliseconds) layout-start))))
      (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))

(define (dashboard:runs-tab-updater commondat tab-num)
  (debug:catch-and-dump 
   (lambda ()

Modified dcommon.scm from [3e06f7ec07] to [a31b0b33bd].

917
918
919
920
921
922
923


924
925
926

927
928
929
930


931
932
933
934
935

936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963


964
965
966
967

968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008

(define (dcommon:command-runname-selector commondat tabdat #!key (tab-num #f)) ;; alldat data)
  (iup:frame
   #:title "Runname"
   (let* ((default-run-name (seconds->work-week/day (current-seconds)))
	  (tb (iup:textbox #:expand "HORIZONTAL"
			   #:action (lambda (obj val txt)


				      ;; (print "obj: " obj " val: " val " unk: " unk)
				      (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE"))
				      (dashboard:update-run-command tabdat))

			   #:value (or default-run-name (dboard:tabdat-run-name tabdat))))
	  (lb (iup:listbox #:expand "HORIZONTAL"
			   #:dropdown "YES"
			   #:action (lambda (obj val index lbstate)


				      (if (not (equal? val ""))
					  (begin
					    (iup:attribute-set! tb "VALUE" val)
					    (dboard:tabdat-run-name-set! tabdat val)
					    (dashboard:update-run-command tabdat))))))

	  (refresh-runs-list (lambda ()
			       (if (dashboard:database-changed? commondat tabdat)
				   (let* ((target        (dboard:tabdat-target-string tabdat))
					  (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" target #f #f #f))
					  (runs-header   (vector-ref runs-for-targ 0))
					  (runs-dat      (vector-ref runs-for-targ 1))
					  (run-names     (cons default-run-name 
							       (map (lambda (x)
								      (db:get-value-by-header x runs-header "runname"))
								    runs-dat))))
				     ;; (iup:attribute-set! lb "REMOVEITEM" "ALL")
				     (iuplistbox-fill-list lb run-names selected-item: default-run-name))))))
     ;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list)
     (dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num)
     (refresh-runs-list)
     (dboard:tabdat-run-name-set! tabdat default-run-name)
     (iup:hbox
      tb
      lb))))

(define (dcommon:command-testname-selector commondat tabdat update-keyvals key-listboxes)
  (iup:frame
   #:title "SELECTORS"
   (iup:vbox
    ;; Text box for test patterns
    (iup:frame
     #:title "Test patterns (one per line)"
     (let ((tb (iup:textbox #:action (lambda (val a b)


				       (dboard:tabdat-test-patts-set!-use
					tabdat
					(dboard:lines->test-patt b))
				       (dashboard:update-run-command tabdat))

			    #:value (dboard:test-patt->lines
				     (dboard:tabdat-test-patts-use tabdat))
			    #:expand "YES"
			    #:size "x50"
			    #:multiline "YES")))
       (set! test-patterns-textbox tb)
       tb))
    (iup:frame
     #:title "Target"
     ;; Target selectors
     (apply iup:hbox
	    (let* ((dat      (dashboard:update-target-selector key-listboxes action-proc: update-keyvals))
		   (key-lb   (car dat))
		   (combos   (cadr dat)))
	      (set! key-listboxes key-lb)
	      combos)))
    (iup:hbox
     ;; Text box for STATES
     (iup:frame
      #:title "States"
      (dashboard:text-list-toggle-box 
       ;; Move these definitions to common and find the other useages and replace!
       (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
       (lambda (all)
	 (dboard:tabdat-states-set! tabdat all)
	 (dashboard:update-run-command tabdat))))
     ;; Text box for STATES
     (iup:frame
      #:title "Statuses"
      (dashboard:text-list-toggle-box 
       (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
       (lambda (all)
	 (dboard:tabdat-statuses-set! tabdat all)
	 (dashboard:update-run-command tabdat))))))))

(define (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state)
  (iup:frame
   #:title "Tests and Tasks"
   (let* ((updater #f)
	  (last-xadj 0)
	  (last-yadj 0)







>
>
|
|
|
>




>
>
|
|
|
|
|
>




















|
<
<
|
|
|
|
|
>
>
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962


963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988

989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014

(define (dcommon:command-runname-selector commondat tabdat #!key (tab-num #f)) ;; alldat data)
  (iup:frame
   #:title "Runname"
   (let* ((default-run-name (seconds->work-week/day (current-seconds)))
	  (tb (iup:textbox #:expand "HORIZONTAL"
			   #:action (lambda (obj val txt)
				      (debug:catch-and-dump
				       (lambda ()
					 ;; (print "obj: " obj " val: " val " unk: " unk)
					 (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE"))
					 (dashboard:update-run-command tabdat))
				       "command-runname-selector tb action"))
			   #:value (or default-run-name (dboard:tabdat-run-name tabdat))))
	  (lb (iup:listbox #:expand "HORIZONTAL"
			   #:dropdown "YES"
			   #:action (lambda (obj val index lbstate)
				      (debug:catch-and-dump
				       (lambda ()
					 (if (not (equal? val ""))
					     (begin
					       (iup:attribute-set! tb "VALUE" val)
					       (dboard:tabdat-run-name-set! tabdat val)
					       (dashboard:update-run-command tabdat))))
				       "command-runname-selector lb action"))))
	  (refresh-runs-list (lambda ()
			       (if (dashboard:database-changed? commondat tabdat)
				   (let* ((target        (dboard:tabdat-target-string tabdat))
					  (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" target #f #f #f))
					  (runs-header   (vector-ref runs-for-targ 0))
					  (runs-dat      (vector-ref runs-for-targ 1))
					  (run-names     (cons default-run-name 
							       (map (lambda (x)
								      (db:get-value-by-header x runs-header "runname"))
								    runs-dat))))
				     ;; (iup:attribute-set! lb "REMOVEITEM" "ALL")
				     (iuplistbox-fill-list lb run-names selected-item: default-run-name))))))
     ;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list)
     (dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num)
     (refresh-runs-list)
     (dboard:tabdat-run-name-set! tabdat default-run-name)
     (iup:hbox
      tb
      lb))))

(define (dcommon:command-testname-selector commondat tabdat update-keyvals) ;;  key-listboxes)


  (iup:vbox
   ;; Text box for test patterns
   (iup:frame
    #:title "Test patterns (one per line)"
    (let ((tb (iup:textbox #:action (lambda (val a b)
				      (debug:catch-and-dump
				       (lambda ()
					 (dboard:tabdat-test-patts-set!-use
					  tabdat
					  (dboard:lines->test-patt b))
					 (dashboard:update-run-command tabdat))
				       "command-testname-selector tb action"))
			   #:value (dboard:test-patt->lines
				    (dboard:tabdat-test-patts-use tabdat))
			   #:expand "YES"
			   #:size "x30"
			   #:multiline "YES")))
      (set! test-patterns-textbox tb)
      tb))
   (iup:frame
    #:title "Target"
    ;; Target selectors
    (apply iup:hbox
	   (let* ((dat      (dashboard:update-target-selector tabdat action-proc: update-keyvals))
		  (key-lb   (car dat))
		  (combos   (cadr dat)))

	     combos)))
   (iup:hbox
    ;; Text box for STATES
    (iup:frame
     #:title "States"
     (dashboard:text-list-toggle-box 
      ;; Move these definitions to common and find the other useages and replace!
      (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
      (lambda (all)
	(dboard:tabdat-states-set! tabdat all)
	(dashboard:update-run-command tabdat))))
    ;; Text box for STATES
    (iup:frame
     #:title "Statuses"
     (dashboard:text-list-toggle-box 
      (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
      (lambda (all)
	(dboard:tabdat-statuses-set! tabdat all)
	(dashboard:update-run-command tabdat)))))))

(define (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state)
  (iup:frame
   #:title "Tests and Tasks"
   (let* ((updater #f)
	  (last-xadj 0)
	  (last-yadj 0)