Megatest

Check-in [f8c1c8f6a6]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Moved most globals into struct.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60_defunct
Files: files | file ages | folders
SHA1: f8c1c8f6a67cb2af4c52240ec9cd300708daf467
User & Date: matt on 2016-03-14 22:11:48
Other Links: branch diff | manifest | tags
Context
2016-03-14
23:18
Last of the globals for now check-in: fca2125702 user: matt tags: v1.60_defunct
22:11
Moved most globals into struct. check-in: f8c1c8f6a6 user: matt tags: v1.60_defunct
02:53
Moving globals into a struct (currently also global :) ) check-in: 69dbbbec4b user: matt tags: v1.60_defunct
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dashboard.scm from [b3a00b95a1] to [8f457fd3fa].

︙︙
91
92
93
94
95
96
97
98
99
100







101
102
103
104
105
106
107
108
109
110









111
112
113
114
115
116
117

;; create a stuct for all the miscellaneous state
;;
(defstruct d:alldat 
  dbdir          dblocal     dbfpath
  keys           dbkeys      header      
  allruns        useserver   ro
  allruns-by-id  buttondat   searchpatts
  numruns        tot-runs    
  last-db-update 
  please-update  )








(define *alldat* (make-d:alldat
		  header: #f 
		  allruns: '()
		  allruns-by-id: (make-hash-table)
		  buttondat: (make-hash-table)
		  searchpatts: (make-hash-table)
		  numruns: 16
		  last-db-update: 0
		  please-update: #t))










(d:alldat-useserver-set! *alldat* (cond
				   ((args:get-arg "-use-local") #f)
				   ((configf:lookup *configdat* "dashboard" "use-server")
				    (let ((ans (config:lookup *configdat* "dashboard" "use-server")))
				      (if (equal? ans "yes") #t #f)))
				   (else #t)))








|
|
|
>
>
>
>
>
>
>









|
>
>
>
>
>
>
>
>
>








91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133

;; create a stuct for all the miscellaneous state
;;
(defstruct d:alldat 
  dbdir          dblocal     dbfpath
  keys           dbkeys      header      
  allruns        useserver   ro
  allruns-by-id  buttondat   searchpatts
  numruns        tot-runs    num-tests
  last-db-update updating
  please-update  
  update-mutex
  item-test-names
  start-run-offset
  start-test-offset
  status-ignore-hash
  state-ignore-hash
 )

(define *alldat* (make-d:alldat
		  header: #f 
		  allruns: '()
		  allruns-by-id: (make-hash-table)
		  buttondat: (make-hash-table)
		  searchpatts: (make-hash-table)
		  numruns: 16
		  last-db-update: 0
		  please-update: #t
		  updating: #f
		  update-mutex: (make-mutex)
		  item-test-names: '()
		  num-tests: 15
		  start-run-offset: 0
		  start-test-offset: 0
		  status-ignore-hash: (make-hash-table)
		  state-ignore-hash: (make-hash-table)
		  ))

(d:alldat-useserver-set! *alldat* (cond
				   ((args:get-arg "-use-local") #f)
				   ((configf:lookup *configdat* "dashboard" "use-server")
				    (let ((ans (config:lookup *configdat* "dashboard" "use-server")))
				      (if (equal? ans "yes") #t #f)))
				   (else #t)))
︙︙
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

(d:alldat-tot-runs-set! *alldat* (if (d:alldat-useserver *alldat*)
				     (rmt:get-num-runs "%")
				     (db:get-num-runs (d:alldat-dblocal *alldat*) "%")))

;; Update management
;;

(define *delayed-update* 0)
(define *update-is-running* #f)
(define *update-mutex* (make-mutex))

(define *all-item-test-names* '())
(define *num-tests*     15)
(define *start-run-offset*  0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *status-ignore-hash* (make-hash-table))
(define *state-ignore-hash*  (make-hash-table))

(define *tests-sort-options* (vector (vector "Sort +a" 'testname   "ASC")
				     (vector "Sort -a" 'testname   "DESC")
				     (vector "Sort +t" 'event_time "ASC")
				     (vector "Sort -t" 'event_time "DESC")
				     (vector "Sort +s" 'statestatus "ASC")
				     (vector "Sort -s" 'statestatus "DESC")
				     (vector "Sort +a" 'testname   "ASC")))








<
<
<
<
<
<
<
<
<
<
<
<
<








147
148
149
150
151
152
153













154
155
156
157
158
159
160

(d:alldat-tot-runs-set! *alldat* (if (d:alldat-useserver *alldat*)
				     (rmt:get-num-runs "%")
				     (db:get-num-runs (d:alldat-dblocal *alldat*) "%")))

;; Update management
;;














(define *tests-sort-options* (vector (vector "Sort +a" 'testname   "ASC")
				     (vector "Sort -a" 'testname   "DESC")
				     (vector "Sort +t" 'event_time "ASC")
				     (vector "Sort -t" 'event_time "DESC")
				     (vector "Sort +s" 'statestatus "ASC")
				     (vector "Sort -s" 'statestatus "DESC")
				     (vector "Sort +a" 'testname   "ASC")))
︙︙
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267

	    test1-older))))
    
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (if (d:alldat-useserver *alldat*)
			  (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts)
			  (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      *start-run-offset* keypatts)))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0)
	 (states      (hash-table-keys *state-ignore-hash*))
	 (statuses    (hash-table-keys *status-ignore-hash*))
	 (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)))
    ;; 








|

|




|
|








248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270

	    test1-older))))
    
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (if (d:alldat-useserver *alldat*)
			  (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset *alldat*) keypatts)
			  (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      (d:alldat-start-run-offset *alldat*) keypatts)))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0)
	 (states      (hash-table-keys (d:alldat-state-ignore-hash *alldat*)))
	 (statuses    (hash-table-keys (d:alldat-status-ignore-hash *alldat*)))
	 (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)))
    ;;
︙︙
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310

						     (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
						   (delete-duplicates (append tmptests prev-tests)
								      (lambda (a b)
									(eq? (db:test-get-id a)(db:test-get-id b)))))))
				      (if (eq? *tests-sort-reverse* 3) ;; +event_time
					(sort newdat compare-tests)
					newdat))))
		  ;; NOTE: bubble-up also sets the global *all-item-test-names*
		  ;; (tests       (bubble-up tmptests priority: bubble-type))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
		  ;; Not sure this is needed?
		  (set! referenced-run-ids (cons run-id referenced-run-ids))
		  (if (> (length tests) maxtests)
		      (set! maxtests (length tests)))








|








299
300
301
302
303
304
305
306
307
308
309
310
311
312
313

						     (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
						   (delete-duplicates (append tmptests prev-tests)
								      (lambda (a b)
									(eq? (db:test-get-id a)(db:test-get-id b)))))))
				      (if (eq? *tests-sort-reverse* 3) ;; +event_time
					(sort newdat compare-tests)
					newdat))))
		  ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names *alldat*)
		  ;; (tests       (bubble-up tmptests priority: bubble-type))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
		  ;; Not sure this is needed?
		  (set! referenced-run-ids (cons run-id referenced-run-ids))
		  (if (> (length tests) maxtests)
		      (set! maxtests (length tests)))
︙︙
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462

	       (if (equal? ipath "")
		   ;; This a top level, prepend it
		   (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '())))
		   ;; This is item, append it
		   (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat))))))
	   test-dats)
	  ;; Set all tests with items 
	  (set! *all-item-test-names* (append (if (null? tnames)
						  '()
						  (filter (lambda (tname)
							    (let ((tlst (hash-table-ref tests tname)))
							      (and (list tlst)
								   (> (length tlst) 1))))
							  tnames))
					      *all-item-test-names*))
	  (let loop ((hed (car tnames))
		     (tal (cdr tnames))
		     (res '()))
	    (let ((newres (append res (hash-table-ref tests hed))))
	      (if (null? tal)
		  newres
		  (loop (car tal)(cdr tal) newres))))))))








|
|
|
|
|
|
|
|








444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465

	       (if (equal? ipath "")
		   ;; This a top level, prepend it
		   (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '())))
		   ;; This is item, append it
		   (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat))))))
	   test-dats)
	  ;; Set all tests with items 
	  (d:alldat-item-test-names-set! *alldat* (append (if (null? tnames)
							      '()
							      (filter (lambda (tname)
									(let ((tlst (hash-table-ref tests tname)))
									  (and (list tlst)
									       (> (length tlst) 1))))
								      tnames))
							  (d:alldat-item-test-names *alldat*)))
	  (let loop ((hed (car tnames))
		     (tal (cdr tnames))
		     (res '()))
	    (let ((newres (append res (hash-table-ref tests hed))))
	      (if (null? tal)
		  newres
		  (loop (car tal)(cdr tal) newres))))))))
︙︙
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499

			     (if (not (member testname *alltestnamelst*))
				 (begin
				   (set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
			   testnames)))))
     runs)

    (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness
    (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*)
					 (drop *alltestnamelst* *start-test-offset*)
					 '())))
			     (append xl (make-list (- *num-tests* (length xl)) ""))))
    (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) "") (d:alldat-keys *alldat*)))));; 3)))
       (let* ((run      (vector-ref rundat 0))








|
|

|








485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502

			     (if (not (member testname *alltestnamelst*))
				 (begin
				   (set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
			   testnames)))))
     runs)

    (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness
    (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) (d:alldat-start-test-offset *alldat*))
					 (drop *alltestnamelst* (d:alldat-start-test-offset *alldat*))
					 '())))
			     (append xl (make-list (- (d:alldat-num-tests *alldat*) (length xl)) ""))))
    (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) "") (d:alldat-keys *alldat*)))));; 3)))
       (let* ((run      (vector-ref rundat 0))
︙︙
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593

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

(define (set-bg-on-filter)
  (let ((search-changed (not (null? (filter (lambda (key)
					      (not (equal? (hash-table-ref (d:alldat-searchpatts *alldat*) key) "%")))
					    (hash-table-keys (d:alldat-searchpatts *alldat*))))))
	(state-changed  (not (null? (hash-table-keys *state-ignore-hash*))))
	(status-changed (not (null? (hash-table-keys *status-ignore-hash*)))))
    (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR"
			(if (or search-changed
				state-changed
				status-changed)
			    "190 180 190"
			    "190 190 190"
			    ))))

(define (update-search x val)
  (hash-table-set! (d:alldat-searchpatts *alldat*) x val)
  (set-bg-on-filter))

(define (mark-for-update)
  (d:alldat-last-db-update-set! *alldat* 0)
  (set! *delayed-update* 1))

;;======================================================================
;; R U N C O N T R O L
;;======================================================================

;; target populating logic
;;  








|
|













|
<








566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588

589
590
591
592
593
594
595

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

(define (set-bg-on-filter)
  (let ((search-changed (not (null? (filter (lambda (key)
					      (not (equal? (hash-table-ref (d:alldat-searchpatts *alldat*) key) "%")))
					    (hash-table-keys (d:alldat-searchpatts *alldat*))))))
	(state-changed  (not (null? (hash-table-keys (d:alldat-state-ignore-hash *alldat*)))))
	(status-changed (not (null? (hash-table-keys (d:alldat-status-ignore-hash *alldat*))))))
    (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR"
			(if (or search-changed
				state-changed
				status-changed)
			    "190 180 190"
			    "190 190 190"
			    ))))

(define (update-search x val)
  (hash-table-set! (d:alldat-searchpatts *alldat*) x val)
  (set-bg-on-filter))

(define (mark-for-update)
  (d:alldat-last-db-update-set! *alldat* 0))


;;======================================================================
;; R U N C O N T R O L
;;======================================================================

;; target populating logic
;;
︙︙
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

			  (system cmd)))))
	 (updater  (lambda ()
		     (let* ((runs-dat     (if (d:alldat-useserver *alldat*)
					      (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f)
					      (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f)))
			    (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
			    (run-id       (dboard:data-get-curr-run-id *data*))

			    (tests-dat    (let ((tdat (if run-id
							  (if (d:alldat-useserver *alldat*)
							      (rmt:get-tests-for-run run-id 
										     (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
										     (hash-table-keys *state-ignore-hash*) ;; '()
										     (hash-table-keys *status-ignore-hash*) ;; '()
										     #f #f
										     *hide-not-hide*
										     #f #f
										     "id,testname,item_path,state,status") ;; get 'em all

							      (db:get-tests-for-run db run-id 
										    (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
										    (hash-table-keys *state-ignore-hash*) ;; '()
										    (hash-table-keys *status-ignore-hash*) ;; '()
										    #f #f
										    *hide-not-hide*
										    #f #f
										    "id,testname,item_path,state,status"))

							  '()))) ;; get 'em all
					    (sort tdat (lambda (a b)
							 (let* ((aval (vector-ref a 2))
								(bval (vector-ref b 2))
								(anum (string->number aval))
								(bnum (string->number bval)))
							   (if (and anum bnum)
							       (< anum bnum)
							       (string<= aval bval)))))))
			    (tests-mindat (dcommon:minimize-test-data tests-dat))
			    (indices      (common:sparse-list-generate-index tests-mindat)) ;;  proc: set-cell))
			    (row-indices  (cadr indices))
			    (col-indices  (car indices))
			    (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
			    (max-col      (if (null? col-indices) 1 (common:max (map cadr col-indices))))
			    (max-visible  (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window
			    (numrows      1)
			    (numcols      1)
			    (changed      #f)
			    (runs-hash    (let ((ht (make-hash-table)))
					    (for-each (lambda (run)
							(hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
						      (vector-ref runs-dat 1))








>




|
|



|
>


|
|



|
>















|








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

			  (system cmd)))))
	 (updater  (lambda ()
		     (let* ((runs-dat     (if (d:alldat-useserver *alldat*)
					      (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f)
					      (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f)))
			    (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
			    (run-id       (dboard:data-get-curr-run-id *data*))
			    (last-update  0) ;; fix me
			    (tests-dat    (let ((tdat (if run-id
							  (if (d:alldat-useserver *alldat*)
							      (rmt:get-tests-for-run run-id 
										     (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
										     (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
										     (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
										     #f #f
										     *hide-not-hide*
										     #f #f
										     "id,testname,item_path,state,status"
										     last-update) ;; get 'em all
							      (db:get-tests-for-run db run-id 
										    (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
										    (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
										    (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
										    #f #f
										    *hide-not-hide*
										    #f #f
										    "id,testname,item_path,state,status"
										    last-update))
							  '()))) ;; get 'em all
					    (sort tdat (lambda (a b)
							 (let* ((aval (vector-ref a 2))
								(bval (vector-ref b 2))
								(anum (string->number aval))
								(bnum (string->number bval)))
							   (if (and anum bnum)
							       (< anum bnum)
							       (string<= aval bval)))))))
			    (tests-mindat (dcommon:minimize-test-data tests-dat))
			    (indices      (common:sparse-list-generate-index tests-mindat)) ;;  proc: set-cell))
			    (row-indices  (cadr indices))
			    (col-indices  (car indices))
			    (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
			    (max-col      (if (null? col-indices) 1 (common:max (map cadr col-indices))))
			    (max-visible  (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) is proportional to the size of the window
			    (numrows      1)
			    (numcols      1)
			    (changed      #f)
			    (runs-hash    (let ((ht (make-hash-table)))
					    (for-each (lambda (run)
							(hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
						      (vector-ref runs-dat 1))
︙︙
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392

						 (mark-for-update)))
	      (iup:button "Collapse"  #:action (lambda (obj)
						 (let ((myname (iup:attribute obj "TITLE")))
						   (if (equal? myname "Collapse")
						       (begin
							 (for-each (lambda (tname)
								     (hash-table-set! *collapsed* tname #t))
								   *all-item-test-names*)
							 (iup:attribute-set! obj "TITLE" "Expand"))
						       (begin
							 (for-each (lambda (tname)
								     (hash-table-delete! *collapsed* tname))
								   (hash-table-keys *collapsed*))
							 (iup:attribute-set! obj "TITLE" "Collapse"))))
						 (mark-for-update))))))
	   (iup:frame 
	    #:title "state/status filter"
	    (iup:vbox
	     (apply 
	      iup:hbox
	      (map (lambda (status)
		     (iup:toggle status  #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *status-ignore-hash* status #t)
							  (hash-table-delete! *status-ignore-hash* status))
						      (set-bg-on-filter))))
		   (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
	     (apply 
	      iup:hbox
	      (map (lambda (state)
		     (iup:toggle state   #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *state-ignore-hash* state #t)
							  (hash-table-delete! *state-ignore-hash* state))
						      (set-bg-on-filter))))
		   (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
	     (iup:valuator #:valuechanged_cb (lambda (obj)
					       (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
						     (oldmax   (string->number (iup:attribute obj "MAX")))
						     (maxruns  (d:alldat-tot-runs *alldat*)))
						 (set! *start-run-offset* val)
						 (mark-for-update)
						 (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
						 (iup:attribute-set! obj "MAX" (* maxruns 10))))
			   #:expand "HORIZONTAL"
			   #:max (* 10 (length (d:alldat-allruns *alldat*)))
			   #:min 0
			   #:step 0.01)))
					;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1))))
					;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0))))
	   )
	  )
    
    ;; create the left most column for the run key names and the test names 
    (set! lftlst (list (iup:hbox
			(iup:label) ;; (iup:valuator)
			(apply iup:vbox 








|
















|
|








|
|






|

|





|
|








1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397

						 (mark-for-update)))
	      (iup:button "Collapse"  #:action (lambda (obj)
						 (let ((myname (iup:attribute obj "TITLE")))
						   (if (equal? myname "Collapse")
						       (begin
							 (for-each (lambda (tname)
								     (hash-table-set! *collapsed* tname #t))
								   (d:alldat-item-test-names *alldat*))
							 (iup:attribute-set! obj "TITLE" "Expand"))
						       (begin
							 (for-each (lambda (tname)
								     (hash-table-delete! *collapsed* tname))
								   (hash-table-keys *collapsed*))
							 (iup:attribute-set! obj "TITLE" "Collapse"))))
						 (mark-for-update))))))
	   (iup:frame 
	    #:title "state/status filter"
	    (iup:vbox
	     (apply 
	      iup:hbox
	      (map (lambda (status)
		     (iup:toggle status  #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! (d:alldat-status-ignore-hash *alldat*) status #t)
							  (hash-table-delete! (d:alldat-status-ignore-hash *alldat*) status))
						      (set-bg-on-filter))))
		   (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
	     (apply 
	      iup:hbox
	      (map (lambda (state)
		     (iup:toggle state   #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! (d:alldat-state-ignore-hash *alldat*) state #t)
							  (hash-table-delete! (d:alldat-state-ignore-hash *alldat*) state))
						      (set-bg-on-filter))))
		   (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
	     (iup:valuator #:valuechanged_cb (lambda (obj)
					       (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
						     (oldmax   (string->number (iup:attribute obj "MAX")))
						     (maxruns  (d:alldat-tot-runs *alldat*)))
						 (d:alldat-start-run-offset-set! *alldat* val)
						 (mark-for-update)
						 (debug:print 6 "(d:alldat-start-run-offset *alldat*) " (d:alldat-start-run-offset *alldat*) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
						 (iup:attribute-set! obj "MAX" (* maxruns 10))))
			   #:expand "HORIZONTAL"
			   #:max (* 10 (length (d:alldat-allruns *alldat*)))
			   #:min 0
			   #:step 0.01)))
					;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (+ (d:alldat-num-tests *alldat*) 1))))
					;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (if (> (d:alldat-num-tests *alldat*) 0)(- (d:alldat-num-tests *alldat*) 1) 0))))
	   )
	  )
    
    ;; create the left most column for the run key names and the test names 
    (set! lftlst (list (iup:hbox
			(iup:label) ;; (iup:valuator)
			(apply iup:vbox
︙︙
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422

	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst (append lftlst (list (iup:hbox  #:expand "HORIZONTAL"
						     (iup:valuator #:valuechanged_cb (lambda (obj)
										       (let ((val (string->number (iup:attribute obj "VALUE")))
											     (oldmax  (string->number (iup:attribute obj "MAX")))
											     (newmax  (* 10 (length *alltestnamelst*))))
											 (d:alldat-please-update-set! *alldat* #t)
											 (set! *start-test-offset* (inexact->exact (round (/ val 10))))
											 (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax)
											 (if (< val 10)
											     (iup:attribute-set! obj "MAX" newmax))
											 ))
								   #:expand "VERTICAL" 
								   #:orientation "VERTICAL"
								   #:min 0
								   #:step 0.01)








|
|








1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427

	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst (append lftlst (list (iup:hbox  #:expand "HORIZONTAL"
						     (iup:valuator #:valuechanged_cb (lambda (obj)
										       (let ((val (string->number (iup:attribute obj "VALUE")))
											     (oldmax  (string->number (iup:attribute obj "MAX")))
											     (newmax  (* 10 (length *alltestnamelst*))))
											 (d:alldat-please-update-set! *alldat* #t)
											 (d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10))))
											 (debug:print 6 "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax)
											 (if (< val 10)
											     (iup:attribute-set! obj "MAX" newmax))
											 ))
								   #:expand "VERTICAL" 
								   #:orientation "VERTICAL"
								   #:min 0
								   #:step 0.01)
︙︙
1510
1511
1512
1513
1514
1515
1516

1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527

	(set! *hide-not-hide-tabs* tabs)
	tabs)))
    (vector keycol lftcol header runsvec)))

(if (or (args:get-arg "-rows")
	(get-environment-variable "DASHBOARDROWS" ))
    (begin

      (set! *num-tests* (string->number (or (args:get-arg "-rows")
					    (get-environment-variable "DASHBOARDROWS"))))
      (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()))
    (set! *num-tests* (min (max (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20)))

(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

;; Move this stuff to db.scm? I'm not sure that is the right thing to do...








>
|
|

|








1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533

	(set! *hide-not-hide-tabs* tabs)
	tabs)))
    (vector keycol lftcol header runsvec)))

(if (or (args:get-arg "-rows")
	(get-environment-variable "DASHBOARDROWS" ))
    (begin
      (d:alldat-num-tests-set! *alldat* (string->number
					 (or (args:get-arg "-rows")
					     (get-environment-variable "DASHBOARDROWS"))))
      (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()))
    (d:alldat-num-tests-set! *alldat* (min (max (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20)))

(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
︙︙
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596

			    (let ((res '()))
			      (for-each (lambda (key)
					  (if (not (equal? key "runname"))
					      (let ((val (hash-table-ref/default (d:alldat-searchpatts *alldat*) key #f)))
						(if val (set! res (cons (list key val) res))))))
					(d:alldat-dbkeys *alldat*))
			      res))
	     (update-buttons uidat (d:alldat-numruns *alldat*) *num-tests*))
	    ((2)
	     (dashboard:update-run-summary-tab))
	    (else
	     (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f)))
	       (if updater (updater)))))
	  (d:alldat-please-update-set! *alldat* #f)
	  (d:alldat-last-db-update-set! *alldat* modtime)








|








1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602

			    (let ((res '()))
			      (for-each (lambda (key)
					  (if (not (equal? key "runname"))
					      (let ((val (hash-table-ref/default (d:alldat-searchpatts *alldat*) key #f)))
						(if val (set! res (cons (list key val) res))))))
					(d:alldat-dbkeys *alldat*))
			      res))
	     (update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*)))
	    ((2)
	     (dashboard:update-run-summary-tab))
	    (else
	     (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f)))
	       (if updater (updater)))))
	  (d:alldat-please-update-set! *alldat* #f)
	  (d:alldat-last-db-update-set! *alldat* modtime)
︙︙
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676

	(examine-test run-id test-id)
	(begin
	  (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor (d:alldat-dblocal *alldat*)))
 (else
  (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*) (d:alldat-numruns *alldat*) *num-tests* (d:alldat-dbkeys *alldat*)))
  (iup:callback-set! *tim*
		     "ACTION_CB"
		     (lambda (x)
		       (let ((update-is-running #f))
			 (mutex-lock! *update-mutex*)
			 (set! update-is-running *update-is-running*)
			 (if (not update-is-running)
			     (set! *update-is-running* #t))
			 (mutex-unlock! *update-mutex*)
			 (if (not update-is-running)
			   (begin
			     (dashboard:run-update x)
			     (mutex-lock! *update-mutex*)
			     (set! *update-is-running* #f)
			     (mutex-unlock! *update-mutex*))))
		       1))))

(let ((th1 (make-thread (lambda ()
			  (thread-sleep! 1)
			  (d:alldat-please-update-set! *alldat* #t)
			  (dashboard:run-update 1)) "update buttons once"))
			  ;; need to wait for first *update-is-running* #t
			  ;; (let loop ()
			  ;;   (mutex-lock! *update-mutex*)
			  ;;   (if *update-is-running*
			  ;;       (begin
			  ;;         (set! *please-update-buttons* #t)
			  ;;         (mark-for-update)
			  ;;         (print "Did redraw trigger")) "First update after startup")
			  ;;   (mutex-unlock! *update-mutex*)
			  ;;   (thread-sleep! 1)
			  ;;   (if (not *please-update-buttons*)
			  ;;       (loop))))))
      (th2 (make-thread iup:main-loop "Main loop")))
  (thread-start! th1)
  (thread-start! th2)
  (thread-join! th2))

;; (iup:main-loop)(db:close-all (d:alldat-dblocal *alldat*))








|




|
|

|
|



|
|
|






|

|
|




|










1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682

	(examine-test run-id test-id)
	(begin
	  (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor (d:alldat-dblocal *alldat*)))
 (else
  (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*) (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*) (d:alldat-dbkeys *alldat*)))
  (iup:callback-set! *tim*
		     "ACTION_CB"
		     (lambda (x)
		       (let ((update-is-running #f))
			 (mutex-lock! (d:alldat-update-mutex *alldat*))
			 (set! update-is-running (d:alldat-updating *alldat*))
			 (if (not update-is-running)
			     (d:alldat-updating-set! *alldat* #t))
			 (mutex-unlock! (d:alldat-update-mutex *alldat*))
			 (if (not update-is-running)
			   (begin
			     (dashboard:run-update x)
			     (mutex-lock! (d:alldat-update-mutex *alldat*))
			     (d:alldat-updating-set! *alldat* #f)
			     (mutex-unlock! (d:alldat-update-mutex *alldat*)))))
		       1))))

(let ((th1 (make-thread (lambda ()
			  (thread-sleep! 1)
			  (d:alldat-please-update-set! *alldat* #t)
			  (dashboard:run-update 1)) "update buttons once"))
			  ;; need to wait for first (d:alldat-updating *alldat*) #t
			  ;; (let loop ()
			  ;;   (mutex-lock! (d:alldat-update-mutex *alldat*))
			  ;;   (if (d:alldat-updating *alldat*)
			  ;;       (begin
			  ;;         (set! *please-update-buttons* #t)
			  ;;         (mark-for-update)
			  ;;         (print "Did redraw trigger")) "First update after startup")
			  ;;   (mutex-unlock! (d:alldat-update-mutex *alldat*))
			  ;;   (thread-sleep! 1)
			  ;;   (if (not *please-update-buttons*)
			  ;;       (loop))))))
      (th2 (make-thread iup:main-loop "Main loop")))
  (thread-start! th1)
  (thread-start! th2)
  (thread-join! th2))

;; (iup:main-loop)(db:close-all (d:alldat-dblocal *alldat*))

Modified dcommon.scm from [5d1caffec5] to [baa39c8e18].

︙︙
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419

			 (let* ((run-stats    (db:get-run-stats dbstruct))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))
				(max-col-vis  (if (> max-col 10) 10 max-col))
				(numrows      1)
				(numcols      1))
			   (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
			   (iup:attribute-set! stats-matrix "NUMCOL" max-col )
			   (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
			   (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)








|








405
406
407
408
409
410
411
412
413
414
415
416
417
418
419

			 (let* ((run-stats    (db:get-run-stats dbstruct))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- (d:alldat-num-tests *alldat*) 15) 3))
				(max-col-vis  (if (> max-col 10) 10 max-col))
				(numrows      1)
				(numcols      1))
			   (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
			   (iup:attribute-set! stats-matrix "NUMCOL" max-col )
			   (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
			   (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
︙︙

This page was generated in about 0.128s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00